Macro to transpose groups of data from rows to columns

[megfitz]

Hello all,

Thanks in advance for any help, I'm really stuck on this one! I have an excel worksheet with data in one row:

The Comfort Hotel
Hotels (Shops & other Retail Outlets) serving London area
3 Leisure Way, London, N12 0QZ
Tel: 020 84466644

Regent Lodge Hotel
Hotels (Shops & other Retail Outlets) serving London area
120 Regents Park Road, London, N3 3HY
Tel: 020 83464439

Holiday In Brent cross
Hotels (Shops & other Retail Outlets) serving London area
Tilling Road, London, NW2 1LP
Tel: 0870-400 9112

The Garth
Hotels (Shops & other Retail Outlets) serving London area
64-76 Hendon Way, London, NW2 2NL
Tel: 020 82091511

But I would like this data to appear as:
The Comfort Hotel Hotels (Shops & other Retail Outlets) serving London area 3 Leisure Way, London, N12 0QZ Tel: 020 84466644
Regent Lodge Hotel Hotels (Shops & other Retail Outlets) serving London area 120 Regents Park Road, London, N3 3HY Tel: 020 83464439
Holiday In Brent cross Hotels (Shops & other Retail Outlets) serving London area Tilling Road, London, NW2 1LP Tel: 0870-400 9112

So the first row of each group of four rows stays in column 1, the second row goes into column 2, the third in column 3, the fourth in column 4 and then after the line break it starts over.

Does anyone have any suggestions?

Thank you so much!
Meg

 

[Weaver]

If your data starts on row 1 in column 1 of sheet1, this should work

It writes the data to a sheet called sheet2, but you can easily change the sheet names if you need to. Just make sure you have a free sheet to paste the data to. The original source data is not affected.

HTH

 Sub trans4x()
    Set src = Sheets("sheet1") 'source data
    Set dst = Sheets("sheet2") 'dstination
    lr = src.Cells(Rows.Count, 1).End(xlUp).Row
    fr = 1 'first row of source data
    pr = 1 'first row of destination
    For i = fr To lr Step 5
        src.Cells(i, 1).Resize(4).Copy
        dst.Cells(pr, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        pr = pr + 1
    Next
    dst.Range("A1:D1").EntireColumn.AutoFit 'resizes cols in destination sheet
End Sub

 

[MickG]

Try This , Results start "H1".
If correct after you've run code Delete unwanted columns

Dim Rng As Range, Dn As Range
Set Rng = Columns("A:A").SpecialCells(xlCellTypeConstants)
    For Each Dn In Rng.Areas
        Range("H" & rows.Count).End(xlUp).Offset(1).Resize(, Dn.Count) = _
        Application.Transpose(Dn)
    Next Dn
End Sub