Excel Vertical to Horizontal Groups VBA

I'm hoping someone can help me with a VBA script to convert a Vertical Table to a Horizontal Table but while preserving grouping. If there are better solutions outside of VBA then I'm open to trying something. I'm using Excel for Mac.

This is what I'm starting with.

All Groups contain a varying number of Rows
All Groups contain the same number of Columns (A - AH / 34 columns)
There are MANY groups (at the moment 432 groups with about 7500 total rows
I could also do this in sub groups - that is, Column C in my dataset could be used to select groups and then only convert these groups.

This VBA script I have currently have will select the current groups based on the Column C Library data name and the active cell:

Sub SelectCurrentLibrary()
Dim searchValue As String
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim rngToSelect As Range

Set ws = ActiveSheet
searchValue = Cells(ActiveCell.Row, 3).Value

' Find the last row in column A
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

' Loop through column A to find matching rows
For Each cell In ws.Range("C3:C" & lastRow)
    If cell.Value = searchValue Then
        If rngToSelect Is Nothing Then
            Set rngToSelect = ws.Range("A" & cell.Row & ":AH" & cell.Row)
        Else
            Set rngToSelect = Union(rngToSelect, ws.Range("A" & cell.Row & ":AH" & cell.Row))
        End If
    End If
Next cell

' Select the final range
If Not rngToSelect Is Nothing Then
    rngToSelect.Select
Else
    MsgBox "No matching rows found."
End If
End Sub

A	B	C	D
GROUP 1	DATA	LIBRARY 1	DATA
GROUP 1	DATA	LIBRARY 1	DATA
GROUP 1	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 3	DATA	LIBRARY 2	DATA
GROUP 3	DATA	LIBRARY 2	DATA
GROUP 3	DATA	LIBRARY 2	DATA
GROUP 3	DATA	LIBRARY 2	DATA

I want to convert this vertical arrangement to a horizontal arrangement (shown below) and paste the data into a new Sheet.
I want to add an empty column between each horizontal grouping
I don't need to copy / convert the header to the horizontal version if that makes things easier

A	B	C	D	F	G	H	I	K	L	M	N
GROUP 1	DATA	DATA	DATA	GROUP 2	DATA	DATA	DATA	GROUP 3	DATA	DATA	DATA
GROUP 1	DATA	DATA	DATA	GROUP 2	DATA	DATA	DATA	GROUP 3	DATA	DATA	DATA
GROUP 1	DATA	DATA	DATA	GROUP 2	DATA	DATA	DATA	GROUP 3	DATA	DATA	DATA
				GROUP 2	DATA	DATA	DATA	GROUP 3	DATA	DATA	DATA
				GROUP 2	DATA	DATA	DATA

If I use the VBA script I have above to select the Range, Excel would still need to copy the individual groups out of that range based on Column A Group name.

Solution

Using Dictionary object to get the range of each group.

Microsoft documentation:

Dictionary object

Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey, Sht As Worksheet
    Dim arrData, ColCnt As Long
    Set objDic = CreateObject("scripting.dictionary")
    Set rngData = Sheets("Sheet1").Range("A1").CurrentRegion
    ' load table into an array
    arrData = rngData.Value
    ColCnt = rngData.Columns.Count
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, 1)
        If objDic.exists(sKey) Then
            Set objDic(sKey) = Union(objDic(sKey), Cells(i, 1))
        Else
            Set objDic(sKey) = Cells(i, 1)
        End If
    Next i
    If objDic.Count = 0 Then Exit Sub
    Dim r As Range, c As Range
    ' add a sheet for output
    Set Sht = Sheets.Add(After:=Sheets(Sheets.Count))
    Set c = Sht.Range("a1")
    For Each sKey In objDic.keys
        With objDic(sKey)
            ' write output to sheet
            c.Resize(.Rows.Count, ColCnt).Value = .Value
        End With
        Set c = c.Offset(, ColCnt + 1)
        If c.Column + ColCnt > Sht.Columns.Count Then ' out of space warning
            MsgBox "There is no more space for output."
            Exit For
        End If
    Next
End Sub

Update: using Array instead of Dict or Collection.

There are three items in a row in aRes().

aRes(x, 0) : group name from Col A
aRes(x, 1) : start row#
aRes(x, 2) : end row#


Sub Demo3()
    Dim rngData As Range
    Dim i As Long, iR As Long, sKey As String
    Dim arrData, ColCnt As Long, RowCnt As Long, aRes()
    Dim Sht As Worksheet: Set Sht = Sheets("Sheet1")
    Const HEADER_CNT = 2 ' Modify as needed
    With Sht.Range("A1").CurrentRegion
        Set rngData = .Offset(HEADER_CNT).Resize(.Rows.Count - HEADER_CNT)
    End With
    ' Sort table w/o header rows
    rngData.Sort Key1:=rngData.Cells(1), Header:=xlNo
    ' load table into an array
    arrData = rngData.Value
    ColCnt = rngData.Columns.Count
    RowCnt = rngData.Rows.Count
    ReDim aRes(1 To RowCnt, 2)
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, 1)
        If iR = 0 Then
            iR = 1
            aRes(iR, 0) = sKey: aRes(iR, 1) = i: aRes(iR, 2) = i
        ElseIf aRes(iR, 0) <> sKey Then
            iR = iR + 1
            aRes(iR, 0) = sKey
        End If
        If IsEmpty(aRes(iR, 1)) Then
            aRes(iR, 1) = i
        End If
        aRes(iR, 2) = i
    Next i
    Dim r As Range, c As Range
    ' add a sheet for output
    Dim ShtNew As Worksheet
    Set ShtNew = Sheets.Add(After:=Sheets(Sheets.Count))
    Set c = ShtNew.Range("a1")
    For i = 1 To iR
        With Range(Sht.Cells(aRes(i, 1) + HEADER_CNT, 1), Sht.Cells(aRes(i, 2) + HEADER_CNT, ColCnt))
            ' write output to sheet
            c.Resize(.Rows.Count, ColCnt).Value = .Value
        End With
        Set c = c.Offset(, ColCnt + 1)
        If c.Column + ColCnt > Sht.Columns.Count Then ' out of space warning
            MsgBox "There is no more space for output."
            Exit For
        End If
    Next
End Sub