Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
This macro "de-pivots" a few columns (and repeats the corresponding rows) to make forming a pivot table easy
Option Explicit
Public Sub TransposeHorizontalToVertical()
Dim lngLastRow As Long, lngIdx As Long, lngOutputLastRow As Long, _
lngDetailsIdx As Long, lngTargetRow As Long, lngTargetCol As Long
Dim wksInput As Worksheet, wksOutput As Worksheet
Dim varDetailNames As Variant, varMonthNames As Variant, _
varDetails As Variant, varValues As Variant
Dim varDetailsKey As Variant, varValuesKey As Variant
Dim dicDetails As Scripting.Dictionary, dicValues As Scripting.Dictionary
'Set references up-front
Set wksInput = ThisWorkbook.Sheets("Raw Data")
Set wksOutput = ThisWorkbook.Sheets.Add
With wksOutput
.Cells(1, 1) = "Area"
.Cells(1, 2) = "Dist"
.Cells(1, 3) = "Parent Retailer"
.Cells(1, 4) = "Product"
.Cells(1, 5) = "Date"
.Cells(1, 6) = "Volume"
End With
lngTargetRow = 2
'Identify the critical details and values on our Input worksheet
With wksInput
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
varDetailNames = .Range("A1:D1")
varMonthNames = .Range("E1:G1")
End With
'Loop through the rows, creating dicts then outputting results
For lngIdx = 2 To lngLastRow
With wksInput
'Initialize the dictionary variables
Set dicDetails = New Scripting.Dictionary
Set dicValues = New Scripting.Dictionary
'Grab the details and the months for this row
varDetails = .Range(.Cells(lngIdx, 1), .Cells(lngIdx, 4))
varValues = .Range(.Cells(lngIdx, 5), .Cells(lngIdx, 7))
End With
'Create the detail dictionary and the value dictionary using
'the custom function written below
Set dicDetails = CreateDictionaryFromRowArrays(varDetailNames, varDetails)
Set dicValues = CreateDictionaryFromRowArrays(varMonthNames, varValues)
With wksOutput
'Loop through the Values dictionary to create output rows
For Each varValuesKey In dicValues.Keys
'Initialize the target column
lngTargetCol = 1
'Write the details to the output sheet
For Each varDetailsKey In dicDetails.Keys
.Cells(lngTargetRow, lngTargetCol) = dicDetails(varDetailsKey)
lngTargetCol = lngTargetCol + 1
Next varDetailsKey
'Write the values (month) to the output sheet
.Cells(lngTargetRow, lngTargetCol) = varValuesKey
lngTargetCol = lngTargetCol + 1
'Write the values (volume) to the output sheet
.Cells(lngTargetRow, lngTargetCol) = dicValues(varValuesKey)
'Increment the row counter
lngTargetRow = lngTargetRow + 1
Next varValuesKey
End With
Next lngIdx
'Let the user know our script is complete!
MsgBox "Data de-pivot complete!"
End Sub
'Custom function for creating dictionaries as needed
Public Function CreateDictionaryFromRowArrays(Keys As Variant, _
Items As Variant) _
As Scripting.Dictionary
Dim lngIdx As Long
Dim dic As Scripting.Dictionary
Set dic = New Scripting.Dictionary
For lngIdx = 1 To UBound(Keys, 2)
dic.Add Key:=Keys(1, lngIdx), Item:=Items(1, lngIdx)
Next lngIdx
Set CreateDictionaryFromRowArrays = dic
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.