Transposed varying Row data to Columns using VBA? - excel

Question

Attached is XLSM (VBA) for transposing rows to columns.
Transpose Varying rows to columns.
If the data is consistent Use TransposeRows the number of columns to be copied and transposed.
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