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:

	QUARTER 1	QUARTER 2	QUARTER 3	QUARTER 4	QUARTER 1
	4Q17 Forecast	4Q17 Forecast	4Q17 Forecast	4Q17 Forecast	1Q18 Forecast
Credit1	124332342.00	234.67	234.23	23.60	0.00
Equity1	89435.98	628.00	112374.29	0.00	347.34
RiskAndCredit2	548734.34	872536.45	0.00	21.96	124.64
EstatePlanning	0.00	7893425675.34	7678254.67	0.00	6591.00

<tbody style="margin: 0px; padding: 0px; border: 0px; font-family: inherit; vertical-align: baseline;">
</tbody>

Desired State:

Credit1	124332342.00	QUARTER 1	4Q17 Forecast
Equity1	89435.98	QUARTER 1	4Q17 Forecast
RiskAndCredit2	548734.34	QUARTER 1	4Q17 Forecast
EstatePlanning	0.00	QUARTER 1	4Q17 Forecast
Credit1	234.67	QUARTER 2	4Q17 Forecast
Equity1	628.00	QUARTER 2	4Q17 Forecast
RiskAndCredit2	872536.45	QUARTER 2	4Q17 Forecast
EstatePlanning	7893425675.34	QUARTER 2	4Q17 Forecast
Credit1	234.23	QUARTER 3	4Q17 Forecast
Equity1	112374.29	QUARTER 3	4Q17 Forecast
RiskAndCredit2	0.00	QUARTER 3	4Q17 Forecast
EstatePlanning	7678254.67	QUARTER 3	4Q17 Forecast
Credit1	23.60	QUARTER 4	4Q17 Forecast
Equity1	0.00	QUARTER 4	4Q17 Forecast
RiskAndCredit2	21.96	QUARTER 4	4Q17 Forecast
EstatePlanning	0.00	QUARTER 4	4Q17 Forecast
Credit1	0.00	QUARTER 1	1Q18 Forecast
Equity1	347.34	QUARTER 1	1Q18 Forecast
RiskAndCredit2	124.64	QUARTER 1	1Q18 Forecast
EstatePlanning	6591.00	QUARTER 1	1Q18 Forecast

<tbody style="margin: 0px; padding: 0px; border: 0px; font-family: inherit; vertical-align: baseline;">
</tbody>

 

[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!