Restructuring repeating columns into rows VBA - excel

Question

I have a wide data set composed of identifiers and then a series of 20 groups of repeating columns, with the same 8 columns in each group. I would like restructure these data into rows such that the identifiers each repeat and each series of 8 represents a unique row.
What I currently have and what I'm trying to accomplish:
I have code that gets me most of the way there, it works if I just run it on the identifiers and the first two columns. It won't go through columns 3-8 of each group. Here is the code that successfully runs on the first two columns of each group.
Sub StackData()
Dim Key, Dic As Object, cl As Range, Data As Range, i&, n&
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
i = Cells(Rows.Count, "A").End(xlUp).Row
n = 1
Set Data = Range("F2:F" & i & "," & "N2:N" & i & "," & "V2:V" & i & "," & "AD2:AD" & i & "," & "AL2:AL" & i & "," & "AT2:AT" & i & "," & "BB2:BB" & i & "," & "BJ2:BJ" & i & "," & "BR2:BR" & i & "," & "BZ2:BZ" & i & "," & "CH2:CH" & i & "," & "CP2:CP" & i & "," & "CX2:CX" & i & "," & "DF2:DF" & i & "," & "DN2:DN" & i & "," & "DV2:DV" & i & "," & "ED2:ED" & i & "," & "EL2:EL" & i & "," & "ET2:ET" & i & "," & "FB2:FB" & i)
Dic.Add "|Name", "Var1|Var2|Var3|Var4|Var5|Var6|Var7|Var8"
For Each cl In Data
If Cells(cl.Row, "A") <> "" Then
Dic.Add n & "|" & Cells(cl.Row, "A"), cl.Text & "|" & cl.Offset(, 1).Text
n = n + 1
End If
Next cl
n = 1
For Each Key In Dic
Worksheets("Worksheet").Cells(n, "A") = Split(Key, "|")(1)
Worksheets("Worksheet").Cells(n, "B") = Split(Dic(Key), "|")(0)
Worksheets("Worksheet").Cells(n, "C") = Split(Dic(Key), "|")(1)
n = n + 1
Next Key
End Sub
When I add to the "For each Key in Dic" I get an error. Any input as to what I am doing wrong? Also open to different ways to approach this that might be cleaner than this kludgey approach.

Answer 1

You can also do this with Power Query, available in Excel 2010+
In the code below I did it using your provided example.
You'll need to make a few changes to adapt it to your actual data.
eg:
In the code, I selected the first two columns and Unpivoted other columns; in your actual data you'll have to select the first three
For the Integer/Division column, I divided by three; you'll probably need to divide by eight
In the code, I added three custom columns (one for each of the identifier columns, and one for the remaining. You'll need to add four custom columns
In any event:
MCode
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Name", "ID"}, "Attribute", "Value"),
#"Added Index" = Table.AddIndexColumn(#"Unpivoted Other Columns", "Index", 0, 1),
#"Inserted Integer-Division" = Table.AddColumn(#"Added Index", "Integer-Division", each Number.IntegerDivide([Index], 3), Int64.Type),
#"Removed Columns" = Table.RemoveColumns(#"Inserted Integer-Division",{"Attribute", "Index"}),
#"Grouped Rows" = Table.Group(#"Removed Columns", {"Integer-Division"}, {{"Grouped", each _, type table [Name=text, ID=number, Value=text, #"Integer-Division"=number]}}),
#"Added Custom" = Table.AddColumn(#"Grouped Rows", "Name", each List.First(Table.Column([Grouped],"Name"))),
#"Added Custom1" = Table.AddColumn(#"Added Custom", "ID", each List.First(Table.Column([Grouped],"ID"))),
#"Added Custom2" = Table.AddColumn(#"Added Custom1", "Custom", each Table.Column([Grouped],"Value")),
#"Extracted Values" = Table.TransformColumns(#"Added Custom2", {"Custom", each Text.Combine(List.Transform(_, Text.From), ";"), type text}),
#"Split Column by Delimiter" = Table.SplitColumn(#"Extracted Values", "Custom", Splitter.SplitTextByDelimiter(";", QuoteStyle.Csv), {"Custom.1", "Custom.2", "Custom.3"}),
#"Changed Type" = Table.TransformColumnTypes(#"Split Column by Delimiter",{{"Custom.1", type text}, {"Custom.2", type text}, {"Custom.3", type text}}),
#"Removed Columns1" = Table.RemoveColumns(#"Changed Type",{"Integer-Division", "Grouped"}),
//Rename last columns
origColNames =List.Buffer(List.Range(Table.ColumnNames(#"Removed Columns1"),2)),
newNameNum = List.Generate(() => 1 , each _ <=List.Count(origColNames), each _ + 1),
//There has to be a better way to convert the numbers to strings
#"Converted to Table" = Table.FromList(newNameNum, Splitter.SplitByNothing(), null, null, ExtraValues.Error),
#"Changed Type1" = Table.TransformColumnTypes(#"Converted to Table",{{"Column1", type text}}),
newNames = Table.Column(#"Changed Type1","Column1"),
renameCols = Table.RenameColumns(#"Removed Columns1",List.Zip({origColNames,newNames}))
in
renameCols

Answer 2

Stack Data
Copy the code into a standard module (e.g. Module1).
Carefully adjust the values under Source, Target and Workbook.
The code is written for Thisworkbook, the workbook containing this code.
The Code
Sub stackData()
' Error Handler
Const Proc As String = "stackData"
On Error GoTo cleanError
' Source
Const srcName As String = "Sheet1" ' Worksheet Name
Const srcFirst As String = "A2" ' First Cell Address
Const LRCol As Long = 1 ' Last Row Column Number
Const IdentCols As Long = 3 ' Number of Identifier Columns
Const GroupCols As Long = 8 ' Number of Group Columns
Const GroupsCount As Long = 20 ' Number of Groups
' Target
Const tgtName As String = "Sheet2" ' Worksheet Name
Const tgtFirst As String = "A2" ' First Cell Address
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Write values of Source Range to Source Array.
Dim ws As Worksheet: Set ws = wb.Worksheets(srcName)
Dim rng As Range
Set rng = ws.Columns(LRCol).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.row < ws.Range(srcFirst).row Then Exit Sub
Dim LastRow As Long: LastRow = rng.row
Set rng = Nothing
Dim LastCol As Long: LastCol = IdentCols + GroupCols * GroupsCount
Dim Source As Variant
Source = ws.Range(ws.Range(srcFirst), ws.Cells(LastRow, LastCol))
Set ws = Nothing
Dim ubS As Long: ubS = UBound(Source)
' Write values of Source Array to Target Array.
Dim Target As Variant
ReDim Target(1 To ubS * GroupsCount, 1 To IdentCols + GroupCols)
Dim i As Long, j As Long, k As Long, m As Long
GoSub writeIdentifiers
GoSub writeGroups
' Write values of Target Array to Target Range.
Set ws = wb.Worksheets(tgtName)
ws.Range(tgtFirst).Resize(UBound(Target), UBound(Target, 2)).Value = Target
' Inform user.
MsgBox "Data stacked.", vbInformation, "Success"
Exit Sub
' Subroutines
writeIdentifiers:
m = 1
For i = 1 To ubS
For j = 1 To GroupsCount
For k = 1 To IdentCols
Target(m, k) = Source(i, k)
Next k
m = m + 1
Next j
Next i
Return
writeGroups:
m = 1
For i = 1 To ubS
For j = 1 To GroupsCount
For k = 1 To GroupCols
Target(m, k + IdentCols) = _
Source(i, k + IdentCols + (j - 1) * GroupCols)
Next k
m = m + 1
Next j
Next i
Return
' Error Handler
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub