How to transpose cells in Excel?

Question

Attached is XLSM (VBA) for transposing rows to columns. Transpose Varying rows to columns.

1. If the data is consistent Use TransposeRows the number of columns to be copied and transposed.
2. If the number of rows for each set is varying then use the TransposeRows2 procedure.

' Please note the code checks the Font color for the end of the record and transposes them to columns so If you need ' anything other than the color Maybe a specific word like 'end' then it can be used instead of the font color.

Sub TransposeRows()
' Convert Rows to Columns specify the range in this case it is 9 rows offset
    Dim rng As Range
    Dim i As Long
    
    Dim MyRange As Range
    Dim lngLastRow As Long

    lngLastRow = Sheet1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    
    MsgBox lngLastRow
    
    Set rng = Sheet1.Range("A1")
    i = 1
    J = 9
    Do While rng.Value <> ""
        rng.Resize(J).Copy
        Sheet2.Range("A" & i).PasteSpecial Transpose:=True
        Set rng = rng.Offset(J)
        'MsgBox Sheet2.Range("A" & i).Font.ColorIndex
        i = i + 1
        
    Loop
    Application.CutCopyMode = False
End Sub

Sub TransposeRows2()

' Transpose Varying rows to columns.
' Please note the code checks the Font color for end of the record and transposes them to columns so If you need
' anything other than the color like say a specific word like end then it can be used instead of the font color.
    Dim rng As Range
    Dim i As Long
    Dim MyRange As Range
    Dim lngLastRow As Long

    lngLastRow = Sheet1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'MsgBox lngLastRow
    
    Set rng = Sheet1.Range("A1")
    i = 1
    J = 0
    K = 1
    J1 = 0
    F = 0
    Do While rng.Value <> ""
        Do Until Sheet1.Range("A" & K).Font.ColorIndex <> 49 And Sheet1.Range("A" & K).Font.ColorIndex <> 16 And Sheet1.Range("A" & K).Font.ColorIndex <> 50 And Sheet1.Range("A" & K).Font.ColorIndex <> 46 And Sheet1.Range("A" & K).Font.ColorIndex <> 55  'And (Sheet1.Range("A" & K).Font.ColorIndex = 50 Or Sheet1.Range("A" & K).Font.ColorIndex = 16)
            K = K + 1
        Loop
            F = F + J
            J = K - F
           ' K = K + 1
            J1 = J
            If Sheet1.Range("A" & K).Font.ColorIndex <> 49 Then
            'If Sheet1.Range("A" & K + 1).Font.ColorIndex = 16 And Sheet1.Range("A" & K + 1).Font.ColorIndex = 18 And Sheet1.Range("A" & K).Font.ColorIndex <> 49 Then
                K = K + 1
            End If
        
        rng.Resize(J).Copy
        If Sheet1.Range("A" & K).Font.ColorIndex = 18 Then 'Or Sheet1.Range("A" & K).Font.ColorIndex = 16 Or Sheet1.Range("A" & K).Font.ColorIndex = 50 Then
            'J = 0
            K = K + 1
        End If
            
        Sheet3.Range("A" & i).PasteSpecial Transpose:=True
        Set rng = rng.Offset(J)
        i = i + 1
    Loop
    Application.CutCopyMode = False
    
    
End Sub

Answer 1

But how would we do it for varying rows like one set being 9 rows and another being 16 rows and so on?

Sub TransposeRows2()
    Dim rng As Range
    Dim i As Long
    Dim MyRange As Range
    Dim lngLastRow As Long

    lngLastRow = Sheet1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'MsgBox lngLastRow
    
    Set rng = Sheet1.Range("A1")
    i = 1
    J = 0
    K = 1
    J1 = 0
    F = 0
    Do While rng.Value <> ""
        Do Until Sheet1.Range("A" & K).Font.ColorIndex <> 49 And Sheet1.Range("A" & K).Font.ColorIndex <> 16 And Sheet1.Range("A" & K).Font.ColorIndex <> 50 And Sheet1.Range("A" & K).Font.ColorIndex <> 46 And Sheet1.Range("A" & K).Font.ColorIndex <> 55  'And (Sheet1.Range("A" & K).Font.ColorIndex = 50 Or Sheet1.Range("A" & K).Font.ColorIndex = 16)
            K = K + 1
        Loop
            F = F + J
            J = K - F
           ' K = K + 1
            J1 = J
            If Sheet1.Range("A" & K).Font.ColorIndex <> 49 Then
            'If Sheet1.Range("A" & K + 1).Font.ColorIndex = 16 And Sheet1.Range("A" & K + 1).Font.ColorIndex = 18 And Sheet1.Range("A" & K).Font.ColorIndex <> 49 Then
                K = K + 1
            End If
        
        rng.Resize(J).Copy
        If Sheet1.Range("A" & K).Font.ColorIndex = 18 Then 'Or Sheet1.Range("A" & K).Font.ColorIndex = 16 Or Sheet1.Range("A" & K).Font.ColorIndex = 50 Then
            'J = 0
            K = K + 1
        End If
            
        Sheet3.Range("A" & i).PasteSpecial Transpose:=True
        Set rng = rng.Offset(J)
        i = i + 1
    Loop
    Application.CutCopyMode = False
        End Sub