Advanced Transposing

[mike4777]

Hello all.

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

Name
Adress
City/State/Zip
Phone
Repeat 100s of times

<tbody>
</tbody>

and make it into this:

Name	Address	City/State/Zip	Phone
Name	Address	City/State/Zip	Phone
etc

<tbody>
</tbody>

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