Transposing a vertical table into a horizontal table

[ainotayev]

Hello.

I would greatly appreciate your help with transposing the vertically formatted data (sheet Current Table) into horizontally formatted data (sheet Desired Macro Output) of the attached file. I have a macro / module which does transpose the data using a hlookup as the basis, however that creates multiple rows per part number with a single cell value per row (sheet Current Macro Output) whereas I need all associated values in a single row as in the example in sheet Desired Macro Output.

The sample file attached is only a small subset of rows / columns. The total array contains 387 columns with values across 2747 unique part numbers spanning 14731 rows.

The current module;

Private Function FetchCategories()


    Dim start_col As Integer, last_col As Integer
    
    start_col = Range("C1").Column
    last_col = Range("D1").Column
    
    Debug.Print last_col - start_col
    
    If last_col + 1 - start_col Mod 2 = 0 Then MsgBox "Selected Column Range is not even for Key Value Pattern", vbCritical, "Invalid Key-Value Range":   Exit Function
    
    Dim coll As Collection
    Set coll = New Collection
    
    Dim srcSht As Worksheet
    Dim outSht As Worksheet


    If Not RemoveSht Then Exit Function
    
    On Error GoTo ERR_HANDLER:
        Sheets("Packed").Activate
        Set srcSht = Sheets("Packed")
        Set outSht = Sheets("Unpacked")
    On Error GoTo 0
    
    total_pack_rows = srcSht.UsedRange.Rows.Count
    
    For icol = start_col To last_col Step 2
        For irow = 2 To total_pack_rows
            On Error Resume Next
                val1 = Cells(irow, icol).Value
                If Len(val1) > 0 Then coll.Add val1, val1
            Err.Clear
            On Error GoTo 0
            
        Next irow
    Next icol
    
    outSht.UsedRange.ClearContents
    
    For i = 1 To coll.Count
        outSht.Cells(1, i).Value = "'" & coll(i)
        outSht.Cells(2, i).Value = i
    Next i
    
    Dim attrib_rng As Range
    Set attrib_rng = outSht.UsedRange
    
    outSht.Activate


    For col_1 = start_col To last_col Step 2
        For row_1 = 2 To total_pack_rows
            attrib_name = srcSht.Cells(row_1, col_1).Value
            If Len(Trim(attrib_name)) > 0 Then
                attrib_col = WorksheetFunction.HLookup(CStr(attrib_name), attrib_rng, 2, False)
                outSht.Cells(row_1 + 1, attrib_col).Value = srcSht.Cells(row_1, col_1 + 1).Value2
            End If
        Next row_1
    Next col_1
    
    outSht.Cells(2, 1).Select
    ActiveCell.EntireRow.Delete xlShiftUp
    
    Exit Function
    
ERR_HANDLER:
    MsgBox "Processing Failed, Reason:" & vbNewLine & Err.Description, vbCritical, "Failed"


End Function


Private Function RemoveSht() As Boolean
    del_success = True
    Application.DisplayAlerts = False
    On Error Resume Next
        Sheets("Unpacked").Delete
        Sheets.Add.Name = "Unpacked"
        If Len(Err.Description) > 0 And Err.Number <> 9 Then del_success = False
        Err.Clear
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    RemoveSht = del_success
End Function

Thanks!

[georgiboy]

I am sure others will be along with another version but I have to go home now so will leave you with what I had created before - albeit very crude.

As you can see from below I had a bit of a counter overload... x, y, n, c, e

Sub test()    
    Dim rng As Range, tmp As String, col As New Collection
    Dim var As Variant, OutVar() As Variant
    Dim x As Long, y As Long, n As Long, c As Long, e As Long
    
    Set rng = Sheet1.UsedRange
    Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
    var = rng.Value
    
    For x = 1 To UBound(var)
        On Error Resume Next
            tmp = var(x, 1)
            col.Add var(x, 1), CStr(var(x, 1)) ' var rows
            If Err.Number <> 0 And var(x, 1) = tmp Then
                c = c + 1
            Else
                If c > e Then
                    e = c: c = 0 ' e = max column count
                End If
            End If
        On Error GoTo 0
    Next x
    
    ReDim OutVar(col.Count - 1, e + 2) ' resize array for the data (+2 for the two fixed columns)
    
    y = -1: n = 2
    For x = 1 To UBound(var)
        If var(x, 1) <> tmp Then
            y = y + 1: n = 2
            OutVar(y, 0) = var(x, 1)
            OutVar(y, 1) = var(x, 2)
            OutVar(y, 2) = var(x, 4)
        Else
            n = n + 1
            OutVar(y, n) = var(x, 4)
        End If
        tmp = var(x, 1)
    Next x
    Sheet3.Range("A2").Resize(UBound(OutVar) + 1, UBound(OutVar, 2) + 1) = OutVar
End Sub

Of course I may have missed the point completely - I am good at that.

Hope this helps

[ainotayev]

Thank you, sir!

[p45cal]

Dead easy in Power Query (it's a single pivot operation).
In attached, just added a few values to the source table for testing. See table at cell A4 of the Desired Macro Output sheet.
To update after changing the data in the source table (Current Table), right click the results table and choose Refresh. (No macros.)

[ainotayev]

Thank you, p45cal! I'll give it a try.

[ainotayev]

[PHP] 

[/PHP]Well, the Power Query pivot is the simply answer, as p45cal proposed.

The settings is used are shown in the attached picture.

Capture.jpg