Help create simple macro

[Richlard]

Please can anyone create a simple macro to transpose this list of a few hundred names and addresses in column A which are in groups of 4 or 5 rows with blank rows in between, into separate columns? Many thanks.

 

[offthelip]

try this, I have assumed the data in is column A and I have writtein it out to columns B to J

Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 1))
Dim outarr()
ReDim outarr(1 To lastrow, 1 To 10)
colno = 1
rowno = 1
blanklast = False
For i = 1 To lastrow
    If inarr(i, 1) = "" Then
        colno = 1
        If Not (blanklast) Then
        rowno = rowno + 1
        blanklast = True
        End If
    Else
    blanklast = False
    outarr(rowno, colno) = inarr(i, 1)
    colno = colno + 1
    End If
Next i
Range(Cells(1, 2), Cells(lastrow, 11)) = outarr

End Sub

 

[Richlard]

Thanks so much. I will try it tomorrow and feedback.

 

[Michael M]

Maybe this...note it starts at cell A1

Sub TransposeAreas()
'original code by Peter_SSs
  Dim aArea As Range, nr As Long
  Application.ScreenUpdating = False
  nr = 2
  For Each aArea In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
    aArea.Copy
    Cells(nr, 3).PasteSpecial Transpose:=True
    nr = nr + 1
  Next aArea
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

 

[Richlard]

Sorry. It hasn't worked. Got this alert:

Subscript out of range (Error 9)​

try this, I have assumed the data in is column A and I have writtein it out to columns B to J

Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 1))
Dim outarr()
ReDim outarr(1 To lastrow, 1 To 10)
colno = 1
rowno = 1
blanklast = False
For i = 1 To lastrow
    If inarr(i, 1) = "" Then
        colno = 1
        If Not (blanklast) Then
        rowno = rowno + 1
        blanklast = True
        End If
    Else
    blanklast = False
    outarr(rowno, colno) = inarr(i, 1)
    colno = colno + 1
    End If
Next i
Range(Cells(1, 2), Cells(lastrow, 11)) = outarr

End Sub

 

[mohadin]

Try

Sub test()
    Dim ar As Range
    Dim i As Long
    i = 1
  For Each ar In Columns("A:A").SpecialCells(2, 3).Areas
        Cells(i, 3).Resize(, ar.Count) = Application.Transpose(ar)
        i = i + 1
    Next
End Sub