Advanced Transposing

[mike4777]

Hello all.

I need to take this in column a (imagine real data):


[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Adress[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]City/State/Zip[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Phone[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Repeat 100s of times[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


and make it into this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]City/State/Zip[/TD]
[TD]Phone[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]City/State/Zip[/TD]
[TD]Phone
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]etc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


I know transpose does this for the whole column... but it will make it stretch into row infinity. Not what I'm wanting.

 

[Joe4]

I have seen people come up with solutions more clever than this one, but since no one has responded yet, I will post this one. It should get the job done.

Sub MyTransposeMacro()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lRow As Long
    Dim r As Long

    Application.ScreenUpdating = False

'   Set worksheet where data currently resides
    Set ws1 = Sheets("Sheet1")
    
'   Set destination worksheet
    Set ws2 = Sheets("Sheet2")
    
'   Set row where first line of data appears on
    r = 1

'   Find last row with data in column A on ws1
    lRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row

'   Loop through all data
    Do Until r > lRow
'       Copy 4 rows
        ws1.Activate
        ws1.Range(Cells(r, "A"), Cells(r + 3, "A")).Copy
'       Paste to destination sheet
        ws2.Activate
        ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
'       Increment counter
        r = r + 4
    Loop
    
    Application.ScreenUpdating = True
    
End Sub