VBA coding - Unpivot Data like Power Query

Question

I need to use VBA code in order to unpivot/reverse a table like a database. I have today the columns for months but i need to have only one column with all the months (like a database).

I know that we can do it with Power query but i need to use VBA

Please see the images to understand :

First Image : Raw data in Table : the table that i need to unpivot (transform) into a database

Second image : the new database : the final databse after the unpivot

Thanks for your help

Answer 1

For a VBA solution

• Organize the data by reading it into a dictionary object
  • the Key will be the Region
  • The item will be a class object which contains a dictionary of the months and values
  • Don't really need a class for this, but might come in handy if extending what you are doing with the data

Please read the notes and comments in the code for important instructions and explanations.

Assuming you will be extending the months to be 12 months, you will need to move the results range. I would suggest a different worksheet.

If you have multiple years of data, you will need to change how you collect and organize the output. eg: if you are adding more than one Jan to a region. As written the code will return an error message and won't allow you to do that. If you decide you want to do something else, you will need to decide exactly what, and then edit the code.

Class Module

'Change name of module to Region
'Region will be the key
'Set reference to Microsoft Scripting Runtime
Option Explicit
Private pMnth As String
Private pMnths As Dictionary
Private pAmt As Long 'or Double if decimals will be needed

Public Property Get Mnth() As String
    Mnth = pMnth
End Property
Public Property Let Mnth(Value As String)
    pMnth = Value
End Property

Public Property Get Mnths() As Dictionary
    Set Mnths = pMnths
End Property
Public Function addMnthsItem(sKey)
    'shouldn't really need this unless data covers multiple years
    If pMnths.Exists(sKey) Then
        MsgBox "Duplicate key will not be added"
    Else
        pMnths.Add Key:=sKey, Item:=pAmt
    End If
End Function

Public Property Get Amt() As Long
    Amt = pAmt
End Property
Public Property Let Amt(Value As Long)
    pAmt = Value
End Property

Private Sub Class_Initialize()
    Set pMnths = New Dictionary
        pMnths.CompareMode = TextCompare
End Sub

Regular Module

'Set reference to Microsoft Scripting Runtime
Option Explicit
Sub unPivotRegion()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dR As Dictionary, cR As cRegion
    Dim I As Long, J As Long, lastRow As Long, lastCol As Long, sKey As String
    Dim numRows As Long
    Dim v, w
    
'Set the source and results worksheets and ranges
Set wsSrc = Worksheets("Sheet4")
Set wsRes = Worksheets("Sheet4") 'or use a different worksheet
    Set rRes = wsRes.Cells(1, 10) 'or something else. just don't overlap with Src
    
'read source data into vba array for fastest processing
With wsSrc
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, 1).End(xlToRight).Column
    vSrc = Range(.Cells(1, 1), .Cells(lastRow, lastCol))
End With

'read and organize into dictionary
Set dR = New Dictionary
    dR.CompareMode = TextCompare
    
For I = 2 To UBound(vSrc, 1)
    Set cR = New cRegion
    sKey = vSrc(I, 1)
    For J = 2 To UBound(vSrc, 2)
        With cR
            .Amt = vSrc(I, J)
            .Mnth = vSrc(1, J)
            If Not dR.Exists(sKey) Then
                .addMnthsItem (.Mnth)
                dR.Add Key:=sKey, Item:=cR
            Else
                dR(sKey).addMnthsItem (.Mnth)
            End If
        End With
    Next J
Next I

'Output in a vertical array
'Calc num of rows
numRows = 0
For Each v In dR.Keys
    numRows = numRows + dR(v).Mnths.Count
Next v

ReDim vRes(0 To numRows, 1 To 3)

'Headers
vRes(0, 1) = "Region"
vRes(0, 2) = "Month"
vRes(0, 3) = "Amount"

'populate the array
I = 0
For Each v In dR.Keys
    For Each w In dR(v).Mnths
        I = I + 1
        vRes(I, 1) = v
        vRes(I, 2) = w
        vRes(I, 3) = dR(v).Mnths(w)
    Next w
Next v
    
'write the results to the worksheet
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
    .Style = "Output" 'may need to alter depending on environment and desires
End With

End Sub

Answer 2

If you would be interested in a non-VBA solution, the following works for Excel Office 365 that supports LET and dynamic arrays.

=LET(data,B2:G5,
     dataRows,ROWS(data),
     dataCols,COLUMNS(data),
     rowHeaders,OFFSET(data,0,-1,dataRows,1),
     colHeaders,OFFSET(data,-1,0,1,dataCols),
     dataIndex,SEQUENCE(dataRows*dataCols),
     rowIndex,MOD(dataIndex-1,dataRows)+1,
     colIndex,INT((dataIndex-1)/dataRows)+1,

     CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)))