Basic Implementation of r-melt for Excel/VBA

rstuff.vba

Option Explicit
Public Function reshapeMelt(options As String) As cDataSet
    
    ' this is a very basic start at vba implementation of Hadley Wickhams  melt(R)
    ' http://www.statmethods.net/management/reshape.html
    Dim jArgs As cJobject, ds As cDataSet, cj As cJobject, _
        R As Range, ws As Worksheet, dr As cDataRow, dsOut As cDataSet, _
        dc As cCell, dsre As cDataSet
        
    ' sort out the options
    Set jArgs = optionsExtend(options, rOptionDefaults)
    
    ' check for argument programming syntax error
    Debug.Assert Not jArgs Is Nothing
    With jArgs
        If .toString("inputsheet") = .toString("outputsheet") Then
            MsgBox ("Reading and writing to the same sheet - not allowed")
            Exit Function
        End If
    End With
    ' read input sheet
    Set ds = New cDataSet
    If ds.populateData _
        (wholeSheet(jArgs.toString("inputsheet")), , , , , , True) Is Nothing Then
        Exit Function
    End If
    
    ' check we have everything we need
    With jArgs
        For Each cj In .child("id").children
            If Not ds.headingRow.validate(.cValue("complain"), cj.toString) Then
                Exit Function
            End If
        Next cj
    ' check if output sheet exists?
        Set ws = sheetExists(.toString("outputSheet"), .cValue("complain"))
        If ws Is Nothing Then
            Exit Function
        End If
     ' good to go
        Set R = ws.Cells(1, 1)
        If .cValue("clearContents") Then
            ws.Cells.ClearContents
        End If
      ' make headings
        For Each cj In .child("id").children
            R.value = cj.value
            Set R = R.Offset(, 1)
        Next cj
        R.value = .toString("variableColumn")
        R.Offset(, 1).value = .toString("valueColumn")
        
        ' lets get that in a dataset for abstracted column access
        Set dsOut = New cDataSet
        dsOut.populateData ws.Cells.Resize(1, R.column + 1)
        
        ' now data
        Set R = dsOut.headingRow.Where.Offset(1).Resize(1, 1)
        For Each dr In ds.rows
            For Each dc In dr.columns
                
                ' need to generate a new row for each non ID cell
                If .child("id").valueIndex _
                        (ds.headings(dc.column).toString) = 0 Then
                    
                    ' the id fields
                    For Each cj In .child("id").children
                        R.Offset(, dsOut.headingRow.exists(cj.toString).column - 1).value = dr.value(cj.toString)
                    Next cj
                    
                    ' this variable value
                    R.Offset(, _
                        dsOut.headingRow.exists(.toString("valueColumn")).column - 1).value _
                            = dc.value
                    ' and its name
                    R.Offset(, _
                        dsOut.headingRow.exists(.toString("variableColumn")).column - 1).value _
                            = ds.headings(dc.column).value
                
                    Set R = R.Offset(1)
                End If
            Next dc

        Next dr
     End With
     ' send back what we just did
     Set dsre = New cDataSet
     Set reshapeMelt = dsre.populateData(dsOut.headingRow.Where.Resize(R.row - 1))
End Function

Public Function rOptionDefaults() As String
    ' this sets up the defaults for all R related stuff
     rOptionDefaults = _
            "{'complain':true, 'inputSheet':'" & ActiveSheet.name & "'," & _
          "'variableColumn' : 'variable', 'valueColumn' : 'value', 'id':['id'] ," & _
          "'outputSheet': 'rOutputData' , 'clearContents':true}"
          
End Function

rstuffsheet.vba

Option Explicit
Public Sub testMelt()
    reshapeMelt "{'outputSheet':'meltOut','id':['id','time']}"
End Sub

For more info see http://ramblings.mcpher.com/Home/excelquirks/json/rmelt