UnPivot with VBA
- I created this monster (a work in progress) a while ago. It is kind of spaghetti code, but it should work in your case.
TESTgetPivot is what you run. Just change Sheet1 and Sheet2 to your worksheet names and adjust the first cells A1 and A2. You won't get the headers though.- This can also easily (in a few clicks) be done with
PowerQuery.
The Code
Option Explicit
Enum RCV
RowsColumnsValues = 1
RowsValuesColumns
ColumnsRowsValues
ColumnsValuesRows
ValuesRowsColumns
ValuesColumnsRows
End Enum
Sub TESTgetPivot()
Dim srcfirst As Range
Set srcfirst = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Dim Data As Variant
Data = getPivot(srcfirst, 2, 1, True, RowsColumnsValues)
If Not IsEmpty(Data) Then
With ThisWorkbook.Worksheets("Sheet2").Range("A2")
'.Worksheet.Cells.ClearContents
.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End With
Else
Debug.Print "No Data."
End If
End Sub
Function getPivot(FirstCell As Range, _
Optional ByVal RowLabels As Long = 1, _
Optional ByVal ColumnLabels As Long = 1, _
Optional ByVal ByColumnLabels As Boolean = False, _
Optional ByVal Order As RCV = RCV.RowsColumnsValues) _
As Variant
' Initialize error handling.
Const ProcName As String = "getPivot"
On Error GoTo clearError
' Validate parameters
If FirstCell Is Nothing Then
GoTo NoCell
End If
If RowLabels < 0 Then
GoTo RowLabelsNegative
End If
If ColumnLabels < 0 Then
GoTo ColumnLabelsNegative
End If
Dim ColRowVal As Variant
ColRowVal = Array("RCV", "RVC", "CRV", "CVR", "VRC", "VCR")
Dim CRV As Variant
CRV = Application.Match(Order, ColRowVal, 0)
If IsError(CRV) Then
ColRowVal = Array(1, 2, 3, 4, 5, 6)
CRV = Application.Match(Order, ColRowVal, 0)
If IsError(CRV) Then
GoTo CRVWrongParameter
End If
End If
' Define Source Range.
' Define Current Region ('rng').
Dim rng As Range
Set rng = FirstCell.CurrentRegion
' Define End Range ('rng').
Set rng = FirstCell _
.Resize(rng.Rows.Count + rng.Row - FirstCell.Row, _
rng.Columns.Count + rng.Column - FirstCell.Column)
' Validate parameters.
' Retrieve Source Rows Count ('srCount').
Dim srCount As Long
srCount = rng.Rows.Count
' Retrieve Source Columns Count ('scCount').
Dim scCount As Long
scCount = rng.Columns.Count
' Declare Target Array ('Target').
Dim Target As Variant
' Validate Row Labels and Column Labels.
If srCount = 1 And scCount = 1 Then
If RowLabels + ColumnLabels = 0 Then
ReDim Target(1 To 1, 1 To 1)
Target(1, 1) = rng.Value
GoTo writeResult
Else
GoTo OneCellOnly
End If
End If
If scCount < RowLabels + 1 Then
GoTo ColumnsDeficit
End If
If srCount < ColumnLabels + 1 Then
GoTo RowsDeficit
End If
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Prepare to write values from Source Array to Target Array.
' Calculate Target Rows Count ('trCount').
Dim trCount As Long
trCount = (srCount - ColumnLabels) * (scCount - RowLabels)
' Calculate Target Columns Count ('tcCount').
Dim tcCount As Long
tcCount = RowLabels + ColumnLabels + 1
' Define Target Array ('Target').
'Dim Target As Variant
ReDim Target(1 To trCount, 1 To tcCount)
' Declare Counters.
Dim i As Long ' Source Rows Counter
Dim j As Long ' Source Columns Counter
Dim k As Long ' Target Rows Counter
Dim l As Long ' Target Columns Counter
' Write values from Source Array to Target Array.
Select Case Order
Case 1 ' "RCV"
If Not ByColumnLabels Then
For i = 1 + ColumnLabels To srCount
For j = 1 + RowLabels To scCount
k = k + 1
For l = 1 To RowLabels
Target(k, l) = Source(i, l) ' R
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - RowLabels, j) ' C
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
Next j
Next i
Else
For j = 1 + RowLabels To scCount
For i = 1 + ColumnLabels To srCount
k = k + 1
For l = 1 To RowLabels
Target(k, l) = Source(i, l) ' R
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - RowLabels, j) ' C
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
Next i
Next j
End If
Case 2 ' "RVC"
If Not ByColumnLabels Then
For i = 1 + ColumnLabels To srCount
For j = 1 + RowLabels To scCount
k = k + 1
For l = 1 To RowLabels
Target(k, l) = Source(i, l) ' R
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - RowLabels - 1, j) ' C
Next l
Next j
Next i
Else
For j = 1 + RowLabels To scCount
For i = 1 + ColumnLabels To srCount
k = k + 1
For l = 1 To RowLabels
Target(k, l) = Source(i, l) ' R
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - RowLabels - 1, j) ' C
Next l
Next i
Next j
End If
Case 3 ' "CRV"
If Not ByColumnLabels Then
For i = 1 + ColumnLabels To srCount
For j = 1 + RowLabels To scCount
k = k + 1
For l = 1 To ColumnLabels
Target(k, l) = Source(l, j) ' C
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - ColumnLabels) ' R
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
Next j
Next i
Else
For j = 1 + RowLabels To scCount
For i = 1 + ColumnLabels To srCount
k = k + 1
For l = 1 To ColumnLabels
Target(k, l) = Source(l, j) ' C
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - ColumnLabels) ' R
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
Next i
Next j
End If
Case 4 ' "CVR"
If Not ByColumnLabels Then
For i = 1 + ColumnLabels To srCount
For j = 1 + RowLabels To scCount
k = k + 1
For l = 1 To ColumnLabels
Target(k, l) = Source(l, j) ' C
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - ColumnLabels - 1) ' R
Next l
Next j
Next i
Else
For j = 1 + RowLabels To scCount
For i = 1 + ColumnLabels To srCount
k = k + 1
For l = 1 To ColumnLabels
Target(k, l) = Source(l, j) ' C
Next l
For l = l To l
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - ColumnLabels - 1) ' R
Next l
Next i
Next j
End If
Case 5 ' "VRC"
If Not ByColumnLabels Then
For i = 1 + ColumnLabels To srCount
For j = 1 + RowLabels To scCount
k = k + 1
For l = 1 To 1
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - 1) ' R
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - RowLabels - 1, j) ' C
Next l
Next j
Next i
Else
For j = 1 + RowLabels To scCount
For i = 1 + ColumnLabels To srCount
k = k + 1
For l = 1 To 1
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - 1) ' R
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - RowLabels - 1, j) ' C
Next l
Next i
Next j
End If
Case 6 ' "VCR"
If Not ByColumnLabels Then
For i = 1 + ColumnLabels To srCount
For j = 1 + RowLabels To scCount
k = k + 1
For l = 1 To 1
Target(k, l) = Source(i, j) ' V
Next l
For l = l To l + ColumnLabels - 1
Target(k, l) = Source(l - 1, j) ' C
Next l
For l = l To l + RowLabels - 1
Target(k, l) = Source(i, l - ColumnLabels - 1) ' R
