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]

Well, the Power Query pivot is the simply answer, as p45cal proposed.

The settings is used are shown in the attached picture.

29778