Hi all, how can I convert the initial Excel table to the final table via VBA (on a separate sheet)?
Asked
Active
Viewed 110 times
-2
-
unpivot. And you'll find plenty of examples searching this forum – Ron Rosenfeld Jan 11 '21 at 11:56
1 Answers
-1
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.
TESTgetPivotis what you run. Just changeSheet1andSheet2to your worksheet names and adjust the first cellsA1andA2. 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
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 + 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
Next l
Next i
Next j
End If
' Not possible
End Select
' Write result and exit.
writeResult:
getPivot = Target
GoTo ProcExit
' Labels
NoCell:
Debug.Print "'" & ProcName & "': No First Cell Range ('Nothing')."
GoTo ProcExit
RowLabelsNegative:
Debug.Print "'" & ProcName & "': Headers Columns can only be 0 or positive."
GoTo ProcExit
ColumnLabelsNegative:
Debug.Print "'" & ProcName & "': Headers Rows can only be 0 or positive."
GoTo ProcExit
CRVWrongParameter:
Debug.Print "'" & ProcName & "': Order can contain either a combination " _
& "of the letters ""R"", ""C"" and ""V"" or a number from 1 to 6."
GoTo ProcExit
OneCellOnly:
Debug.Print "'" & ProcName & "': There is one cell only."
GoTo ProcExit
ColumnsDeficit:
Debug.Print "'" & ProcName & "': Not enough columns."
GoTo ProcExit
RowsDeficit:
Debug.Print "'" & ProcName & "': Not enough rows."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0
GoTo ProcExit
ProcExit:
End Function
- The following image is showing what the code is covering. Your case is the first green one, except that your data has two row labels and one more column.
VBasic2008
- 44,888
- 5
- 17
- 28