Transposing a vertical table into a horizontal table

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;

Code:

---

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!

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

Code:

---

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

Thank you, sir!

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.)

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

PHP Code:

---

[PHP] 


---

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

The settings is used are shown in the attached picture.

Attachment 29778