How to use VBA to loop through list and turn into columns?

I am trying to figure out how I can create a macro to loop through my data that is in 6 rows to a single column with no repeating headers. my data is in the form of:

row1: aaa
row2: bbb
row3: ccc
row4: ddd
row5: eee
row6: fff
row1: 11
row2: 22
row3: 33
row4: 44
row5: 55
row6: 66

and would like to transform it into the form of:

row1:   row2:    row3:     row4:     row5:     row6:
aaa     bbb      ccc       ddd       eee       fff
11      22       33        44        55        66

each entry is in this 6 row format. I have been trying to work with other similar exampled without any real luck.

I have tried some similar examples here, but been able to get it to where the information in the rows do not repeat, since they are the same for each entry in the list

There are many ways of solving this problem.

On way is by using using Power Query, available in Windows Excel 2010+ and Excel 365 (Windows or Mac)

To use Power Query

• Select some cell in your Data Table
• Data => Get&Transform => from Table/Range or from within sheet
• When the PQ Editor opens: Home => Advanced Editor
• Make note of the Table Name in Line 2
• Paste the M Code below in place of what you see
• Change the Table name in line 2 back to what was generated originally.
• Read the comments and explore the Applied Steps to understand the algorithm

let

//change next line to reflect actual table name
    Source = Excel.CurrentWorkbook(){[Name="Table5"]}[Content],

//set the data types
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}}),

//Group by column1 = Column headers
//Generates list of column Contents for each column
    #"Grouped Rows" = Table.Group(#"Changed Type", {"Column1"}, {
        {"cols", each [Column2], type list} }),

    #"New Table" = Table.FromColumns(
        #"Grouped Rows"[cols], #"Grouped Rows"[Column1])

in #"New Table"

There's lots of ways to do it. Here's one that I've tested:

Const NUM_ROWS_PER_GROUP = 6
Const NUM_ROWS = 12  ' This is also easy to calculate at runtime rather than a` constant.

Sub RowsToColumns()
     Dim iRow As Long
     Dim iRow2 As Long
     Dim iRow3 As Long
     Dim iCol As Long
     '
     ' Get the column headers first
     '
     iRow3 = NUM_ROWS + 2
     For iRow = 1 To NUM_ROWS_PER_GROUP
          iCol = iRow
          Me.Cells(iRow3, iCol) = Me.Cells(iRow, 1)
     Next iRow
     '
     ' Now the data
     '
     iRow3 = iRow3 + 1

     For iRow = 1 To NUM_ROWS Step NUM_ROWS_PER_GROUP
         For iRow2 = 1 To NUM_ROWS_PER_GROUP
             iCol = iRow2
             Me.Cells(iRow3, iCol) = Me.Cells(iRow + iRow2 - 1, 2)
         Next iRow2
         iRow3 = iRow3 + 1
     Next iRow
End Sub

Data is something like this :<br>

Expected result starting from cell D1:<br>

Sub test()
Dim r As Integer, rslt As Range, oData As Range, i As Integer

r = 6
Set rslt = Range("D1") 'change if needed
Set oData = Range("B2").Resize(r, 1) 'change if needed
rslt.Resize(1, r).Value = Application.Transpose(oData.Offset(0, -1).Value)

For i = 1 To Application.CountIf(Columns(1), oData.Offset(0, -1)(1, 1).Value)
    Set rslt = rslt.Offset(1, 0)
    rslt.Resize(1, r).Value = Application.Transpose(oData.Value)
    Set oData = oData.Offset(r, 0)
Next

End Sub

r variable is for "how many rows of data" in column B to be tranposed, 6 in this case<br>
rslt variable is the result cell.<br>
oData variable is the first r rows of data in column B.<br>
It create the "header" in the result cell based on the oData.offset(0,-1) <br>

Then it loop as much as the count of "row 1" which reside in column 1, and put the oData value to rslt via transpose.

Please note, the code will fail if for example in cell A2 value is "row 1", but cell A8 value is "row1:", because the loop depends on how many A2 value exists in column A.

It will also fail if for example : range A2:A7 value is from "row 1" to "row 6", but there is only "row 1" to "row 5" in A8:A12 ---> this will fail because the code assumed the data will always has r rows (6 in this case).

example your list in column A and B starting at row 2, transpose starting at D2

Sub TransposeValues()
    Dim lastRow As Long, j As Long
    Dim dict As Object, key As Variant
    Dim rng As Range, nxt As Long, foundcell As Range
    Set dict = CreateObject("Scripting.Dictionary")
    Dim firstAddress
    
    nxt = 3
    lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = ActiveSheet.Range("A2:A" & lastRow)
    
    'Loop through column A and add unique values to dictionary
    For i = 2 To lastRow
        If Not dict.Exists(ActiveSheet.Cells(i, 1).Value) Then
            dict.Add Cells(i, 1).Value, 1
        End If
    Next i
    
    'Loop through dictionary keys and find corresponding values in column B
    For Each key In dict.Keys
        nxt = nxt + 1
        ActiveSheet.Cells(2, nxt).Value = key
        j = 2
        Set foundcell = rng.Find(What:=key, LookIn:=xlValues)
        If Not foundcell Is Nothing Then
            firstAddress = foundcell.Address
            Do
                ActiveSheet.Cells(j + 1, nxt).Value = foundcell.Offset(0, 1).Value
                j = j + 1
                Set foundcell = rng.FindNext(foundcell)
            Loop While Not foundcell Is Nothing And foundcell.Address <> firstAddress
        End If
    Next key
    
End Sub