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!