I have this table that looks similar to this:
And I want to transform it so that it looks like this:
The idea is to unpivot( or transpose) the tabl
Here's a pretty generic depivot approach which handles multiple row/column headers.
Select a cell in the source table before running (note - this uses CurrentRegion
so will fail if your table has completely blank rows or columns).
Sub UnpivotIt()
Dim numRowHeaders As Long, numColHeaders As Long
Dim numRows As Long, numCols As Long, rng As Range
Dim rngOut As Range, r As Long, c As Long, i As Long, n As Long
Dim arrIn, arrOut, outRow As Long
arrIn = Selection.CurrentRegion.Value
numRowHeaders = Application.InputBox("How many header rows?", Type:=1)
numColHeaders = Application.InputBox("How many header columns?", Type:=1)
Set rngOut = Application.InputBox("Select output (top-left cell)", Type:=8)
Set rngOut = rngOut.Cells(1) 'in case >1 cells selected
numRows = UBound(arrIn, 1)
numCols = UBound(arrIn, 2)
ReDim arrOut(1 To ((numRows - numRowHeaders) * (numCols - numColHeaders)), _
1 To (numRowHeaders + numColHeaders + 1))
outRow = 0
For r = (numRowHeaders + 1) To numRows
For c = (numColHeaders + 1) To numCols
'only copy if there's a value
If Len(arrIn(r, c)) > 0 Then
outRow = outRow + 1
i = 1
For n = 1 To numColHeaders 'copy column headers
arrOut(outRow, i) = arrIn(r, n)
i = i + 1
Next n
For n = 1 To numRowHeaders '...row headers
arrOut(outRow, i) = arrIn(n, c)
i = i + 1
Next n
arrOut(outRow, i) = arrIn(r, c) '...and the value
End If
Next c
Next r
rngOut.Resize(outRow, UBound(arrOut, 2)).Value = arrOut
End Sub