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
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
try this, I have assumed the data in is column A and I have writtein it out to columns B to J
VBA Code: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
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