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

--
Message posted from http://www.ExcelForum.com

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 " skrev i meddelandet
...
I am trying to write a macro that will loop at blank lines. My issue is
I am dealing with 100+ addresses that may have 3-6 rows. I want to
transpose them so it is all on one row.

I have been using this when I know the number of rows. Unfortunately it
does not help when there are variable row numbers in the same sheet.
But all the Addresses are seperated by blank lines... any help is
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 Sub


---
Message posted from http://www.ExcelForum.com/

Works Great!!!! Thanks much!


---
Message posted from http://www.ExcelForum.com/

Glad to help, thanks for the feedback.

Anders Silven

"starfish900 " skrev i meddelandet
...
Works Great!!!! Thanks much!


---
Message posted from http://www.ExcelForum.com/