Convert Excel tables from wide to long using VBA

Question

I want, with a VBA code using a loop, to reshape tables from wide to long format.

I prefer VBA for automation purposes, especially that I need to consolidate all the tables into one sheet every time.

Simple sample table:

code	Height	Weight	Color
z123	131	40	0
z876	231	50	1

The final table should be as below. The codes would need to repeat in column A to correspond with the height, weight, and color references specified in column B.

code	Ref	Values
z123	Height	131
z876	Height	231
z123	Weight	40
z876	Weight	50
z123	Color	0
z876	Color	1

Code should be in column A, height, weight , color and other properties should be in column B, and values should be in column C.

Answer 1

If you have your wide table in a MS Access database, placing the below VBA code in a module and running the RotateTable() function would read each column from the original wide table and convert it into a vertical query of three columns, code, ref and ref_value. All you would need to do is change the wide table name in the code. The resultant query matches your desired output

Public Function PickValues(col_name, table_name)
    Dim union_str As String
    union_str = "SELECT code, '" & col_name & "' as Ref,  [" & col_name & "] as ref_value FROM " & table_name & " UNION ALL "
    PickValues = union_str
End Function

Public Sub RotateTable()
    Dim db As DAO.Database
    Dim tdfld As DAO.TableDef
    Dim fld As Field
    Dim table_name As String
    Dim full_union_str As String
     
    table_name = "wide_table" 'change this
    full_union_str = ""
    Set db = CurrentDb()
    Set tdfld = db.TableDefs(table_name)
    For Each fld In tdfld.Fields    'loop through all the fields of the tables
        If Not fld.Name = "code" Then 'Ignore for code column
            col_name = fld.Name
            sub_union_str = PickValues(col_name, table_name)
            full_union_str = full_union_str & sub_union_str
        End If
    Next
    trimmed_select_str = Left(full_union_str, Len(full_union_str) - (Len(" UNION ALL "))) 'this removes the last union string
    Set tdfld = Nothing
    Set db = Nothing
    
    On Error Resume Next
    Set qdf = CurrentDb.CreateQueryDef("qry_rotated", trimmed_select_str)
    DoCmd.OpenQuery qdf.Name
    On Error GoTo 0

End Sub

Answer 2

Rearrange data in row slices and write to ListObject

Apparently OP doesn't want only a simple unpivot action, but to rearrange row values and (over)write a given ListObject. The following code demonstrates this benefitting

• from some pecularities of the Application.Index() function and
• from resizing the ListObject.

Sub Rearrange(rng As Range)
    '[0] get data
    Dim data:        data = rng
    Dim categories:  categories = Application.Index(data, 1, 0)
    '[1] provide for sufficient array rows
    Dim cnt As Long: cnt = UBound(data)
    Dim results: ReDim results(1 To (UBound(categories) - 1) * (cnt - 1))
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '[2] arrange data in wanted order
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim cat As Long
    For cat = 2 To UBound(categories)                ' Height, Weight, Color
        Dim i As Long, ii As Long
        For i = 2 To cnt                             ' e.g. data rows 2:4
            ' collect all relevant data in row columns and
            ' overwrite inserted 2nd col with category
            Dim currData
            currData = Application.Index(data, Evaluate("row(" & i & ":" & i & ")"), Array(1, 0, cat))
            currData(2) = categories(cat)            ' replace 2nd column w/ category
            '
            ii = ii + 1: results(ii) = currData      ' increment row counter
        Next i
    Next cat
    'put array rows together
    results = Application.Index(results, 0, 0)

    '[3] write results to target
    ' a) define captions
    Dim captions: captions = Split("Code,Ref,Value", ",")
    
    ' b) write to another listobject or overwrite given listobject
    '    (~~> change target to your needs)
    With Tabelle1.ListObjects("MyTable2")
        ' Get number of rows to adjust
        Dim rowCorr As Long, colCorr As Long
        rowCorr = UBound(results) - LBound(results) + 1 - .DataBodyRange.Rows.Count
        colCorr = UBound(results, 2) - LBound(results, 2) + 1 - .DataBodyRange.Columns.Count
        Debug.Print "Rows/Cols to adjust = " & rowCorr & "/" & colCorr
        
        'Adjust list object
        If rowCorr < 0 Then            ' Delete Rows
            .DataBodyRange.Rows(1).Resize(Abs(rowCorr)).Delete xlShiftUp
        ElseIf rowCorr > 0 Then        ' Insert rows
            .DataBodyRange.Rows(1).Resize(rowCorr).Insert Shift:=xlDown
        End If
        If colCorr < 0 Then            ' Delete Cols
            .Range.Resize(, Abs(colCorr)).Columns.Delete
        ElseIf colCorr > 0 Then        ' Insert cols
            .Range.Resize(, colCorr).Columns.Insert
        End If
                
        'overwrite data
        .HeaderRowRange = captions
        .DataBodyRange = results
    End With
    
End Sub

Calling code example

You could start the wanted rearrangements e.g. by

    Rearrange Sheet1.ListObjects("MyTable").Range

or even with

    Rearrange Sheet1.Range("A1:D3")

If you might want to write to a range target (of another sheet for instance) instead of a ListObject, you could replace section [3]b) e.g. with

    With Sheet2.Range("A1")
        .Resize(1, UBound(captions) + 1) = captions
        .Offset(1).Resize(UBound(results), UBound(results, 2)) = results
    End With

and/or split the code into several sub procedures.