Looping at Blank Lines

[starfish900]

I am trying to write a macro that will loop at blank lines. My issue i
I am dealing with 100+ addresses that may have 3-6 rows. I want t
transpose them so it is all on one row.

I have been using this when I know the number of rows. Unfortunately i
does not help when there are variable row numbers in the same sheet
But all the Addresses are seperated by blank lines... any help i
appreciated.



Sub Transpose1()

Dim d As Integer
Dim c As Integer

c = 1
d = 6

FinalRow = Range("A9999").End(xlUp).Row
For i = 1 To FinalRow

' Copy data columns, transpose and paste
Range("A" & c & ":A" & d).Copy
Range("B" & i & ":Z" & i).PasteSpecial Paste:=xlPasteAll
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

d = d + 6
c = c + 6
Next i

Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

Cells.Select
Cells.EntireColumn.AutoFit

ActiveWorkbook.Save


End Su

 

[Anders S]

Hi starfish900,

Try this, it might get you going,

'*****
Option Explicit
Sub test43978()
Dim firstRow As Long, lastRow As Long
Dim tRow As Long, firstCol As Integer
Dim rNum As Long, cCol As Integer

'enter starting position here
firstRow = 1
firstCol = 1

cCol = firstCol + 1
rNum = firstRow

Application.ScreenUpdating = False
With ActiveSheet
lastRow = .Cells(Rows.Count, firstCol).End(xlUp).Row
For tRow = firstRow To lastRow
If .Cells(tRow, firstCol) = "" Then
rNum = rNum + 1
cCol = firstCol + 1
GoTo nexttRow
End If
.Cells(rNum, cCol).Value = .Cells(tRow, firstCol).Value
.Cells(tRow, 1).Select
cCol = cCol + 1
nexttRow:
Next tRow
.Cells(firstRow, firstCol).EntireColumn.Delete
End With
Application.ScreenUpdating = True
End Sub
'*****

HTH
Anders Silven

 

[starfish900]

Works Great!!!! Thanks much!

 

[Anders S]

Glad to help, thanks for the feedback.

Anders Silven