unpivot using nested headers (multiple columns)

[oceanBreeze]

Hello all,

I have searched for a few days now how to unpivot via VBA. While I have found some helpful information out there, my situation is unique in that the desire is to unpivot nested headers. Horizontal groupings have levels. For example, below is simple example of what I am trying to do. The Current state is nested header data. I want that data in flattened form so we can import into other tools such as a database or visualization tools.

I would prefer to do this via VBA and not power query or power bi. In the details below there are 2 header levels (Quarters and Forecast and yes they are different values), but it could potentially be groupings up to 6 or even 7.

Does ANYONE know how to do this via VBA with an ability to adjust to include more nested headers??? Please please help!


Current State:
[TABLE="class: text_table"]
<tbody style="margin: 0px; padding: 0px; border: 0px; font-family: inherit; vertical-align: baseline;">[TR]
[TD][/TD]
[TD="width: 117"]QUARTER 1[/TD]
[TD="width: 111"]QUARTER 2[/TD]
[TD="width: 97"]QUARTER 3[/TD]
[TD="width: 94"]QUARTER 4[/TD]
[TD="width: 94"]QUARTER 1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]4Q17 Forecast[/TD]
[TD]4Q17 Forecast[/TD]
[TD]4Q17 Forecast[/TD]
[TD]4Q17 Forecast[/TD]
[TD]1Q18 Forecast[/TD]
[/TR]
[TR]
[TD]Credit1[/TD]
[TD]124332342.00[/TD]
[TD]234.67[/TD]
[TD]234.23[/TD]
[TD]23.60[/TD]
[TD]0.00[/TD]
[/TR]
[TR]
[TD]Equity1[/TD]
[TD]89435.98[/TD]
[TD]628.00[/TD]
[TD]112374.29[/TD]
[TD]0.00[/TD]
[TD]347.34[/TD]
[/TR]
[TR]
[TD]RiskAndCredit2[/TD]
[TD]548734.34[/TD]
[TD]872536.45[/TD]
[TD]0.00[/TD]
[TD]21.96[/TD]
[TD]124.64[/TD]
[/TR]
[TR]
[TD]EstatePlanning[/TD]
[TD]0.00[/TD]
[TD]7893425675.34[/TD]
[TD]7678254.67[/TD]
[TD]0.00[/TD]
[TD]6591.00[/TD]
[/TR]
</tbody>[/TABLE]




Desired State:[TABLE="class: text_table"]
<tbody style="margin: 0px; padding: 0px; border: 0px; font-family: inherit; vertical-align: baseline;">[TR]
[TD]Credit1[/TD]
[TD="width: 117"]124332342.00[/TD]
[TD="width: 111"]QUARTER 1[/TD]
[TD="width: 97"]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Equity1[/TD]
[TD]89435.98[/TD]
[TD]QUARTER 1[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]RiskAndCredit2[/TD]
[TD]548734.34[/TD]
[TD]QUARTER 1[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]EstatePlanning[/TD]
[TD]0.00[/TD]
[TD]QUARTER 1[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Credit1[/TD]
[TD]234.67[/TD]
[TD]QUARTER 2[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Equity1[/TD]
[TD]628.00[/TD]
[TD]QUARTER 2[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]RiskAndCredit2[/TD]
[TD]872536.45[/TD]
[TD]QUARTER 2[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]EstatePlanning[/TD]
[TD]7893425675.34[/TD]
[TD]QUARTER 2[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Credit1[/TD]
[TD]234.23[/TD]
[TD]QUARTER 3[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Equity1[/TD]
[TD]112374.29[/TD]
[TD]QUARTER 3[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]RiskAndCredit2[/TD]
[TD]0.00[/TD]
[TD]QUARTER 3[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]EstatePlanning[/TD]
[TD]7678254.67[/TD]
[TD]QUARTER 3[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Credit1[/TD]
[TD]23.60[/TD]
[TD]QUARTER 4[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Equity1[/TD]
[TD]0.00[/TD]
[TD]QUARTER 4[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]RiskAndCredit2[/TD]
[TD]21.96[/TD]
[TD]QUARTER 4[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]EstatePlanning[/TD]
[TD]0.00[/TD]
[TD]QUARTER 4[/TD]
[TD]4Q17 Forecast[/TD]
[/TR]
[TR]
[TD]Credit1[/TD]
[TD]0.00[/TD]
[TD]QUARTER 1[/TD]
[TD]1Q18 Forecast[/TD]
[/TR]
[TR]
[TD]Equity1[/TD]
[TD]347.34[/TD]
[TD]QUARTER 1[/TD]
[TD]1Q18 Forecast[/TD]
[/TR]
[TR]
[TD]RiskAndCredit2[/TD]
[TD]124.64[/TD]
[TD]QUARTER 1[/TD]
[TD]1Q18 Forecast[/TD]
[/TR]
[TR]
[TD]EstatePlanning[/TD]
[TD]6591.00[/TD]
[TD]QUARTER 1[/TD]
[TD]1Q18 Forecast[/TD]
[/TR]
</tbody>[/TABLE]

 

[ParamRay]

Hello. The following macro should be placed in the same workbook as your source data.

It will unpivot multiple levels of both column headers and row headers.

Please read the assumptions in the code and make sure you change the indicated line of code.

Best regards.

' Assumptions:
' 1 - First header row is row 1
' 2 - Can have multiple header rows
' 3 - First header column is column A
' 4 - Can have multiple header columns
' 5 - Block of cells to the left of the header rows
'     and above the header columns are empty (IMPORTANT!)

Public Sub UnpivotAllLevels()
  Const strSHEET_NAME = "Sheet1"   '<--- Set name of sheet with data (IMPORTANT!)
  Dim avntOutputData() As Variant
  Dim wksOutputSheet As Worksheet
  Dim intHeaderCols As Integer
  Dim lngHeaderRows As Long
  Dim lngOutputCols As Long
  Dim lngOutputRows As Long
  Dim lngOutputCol As Long
  Dim lngOutputRow As Long
  Dim intLastCol As Integer
  Dim lngLastRow As Long
  Dim blnError As Boolean
  Dim i As Integer
  Dim j As Long
  Dim k As Long
  
  On Error GoTo ErrorHandler
  Application.DisplayAlerts = False
  
  With ThisWorkbook.Sheets(strSHEET_NAME)
    lngHeaderRows = .Cells(1, "A").End(xlDown).Row - 1
    intHeaderCols = .Cells(1, "A").End(xlToRight).Column - 1
    lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    intLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lngOutputCols = lngHeaderRows + intHeaderCols + 1
    lngOutputRows = (lngLastRow - lngHeaderRows) * (intLastCol - intHeaderCols)
    ReDim avntOutputData(1 To lngOutputRows, 1 To lngOutputCols)
    
    For i = intHeaderCols + 1 To intLastCol
      For j = lngHeaderRows + 1 To lngLastRow
        lngOutputRow = lngOutputRow + 1
        lngOutputCol = 1
        For k = 1 To intHeaderCols
          avntOutputData(lngOutputRow, lngOutputCol) = .Cells(j, k).Value
          lngOutputCol = lngOutputCol + 1
        Next k
        avntOutputData(lngOutputRow, lngOutputCol) = .Cells(j, i).Value
        For k = 1 To lngHeaderRows
          lngOutputCol = lngOutputCol + 1
          avntOutputData(lngOutputRow, lngOutputCol) = .Cells(k, i).Value
        Next k
      Next j
    Next i
  End With
  
  Set wksOutputSheet = ThisWorkbook.Sheets.Add()
  With wksOutputSheet.Range("A1").Resize(lngOutputRows, lngOutputCols)
    .Value = avntOutputData
    .EntireColumn.AutoFit
  End With
  
ExitHandler:
  On Error Resume Next
  If blnError Then wksOutputSheet.Delete
  Application.DisplayAlerts = True
  Set wksOutputSheet = Nothing
  Exit Sub
  
ErrorHandler:
  MsgBox Err.Description, vbExclamation
  blnError = True
  Resume ExitHandler
End Sub

 

[oceanBreeze]

THANK YOU THANK YOU THANK YOU THANK YOU! This worked great!