Rows to Columns - Diff Size Rows of Data

[Mishelley]

Good Morning,

I have the following that I need to move into rows (records) - same
worksheet is fine. How can I do this when the address blocks are different
sizes (some 3 and some 4 rows)? There is a blank row in between.

Thanks so much in advance!

Mishelley

Name
Address 1
City, State, Zip

Name
Address 1
Address 2
City, State, Zip

Name
Address 1
City, State, Zip

Name
Address 1
Address 2
City, State, Zip

 

[Chip Pearson]

Try some code like the following:

Sub AAA()
Dim LastCell As Long
Dim Dest As Range
Dim R As Range
Dim WS As Worksheet

' Dest is where the records are written
Set Dest = Worksheets("Sheet2").Range("A1")
' WS is worksheet with columnar data
Set WS = Worksheets("Sheet1")
With WS
LastCell = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
' R is first cell of columnar data
Set R = WS.Range("A1")
Do Until R.Row > LastCell
Do Until R.Text = vbNullString
Dest = R.Text
Set Dest = Dest(1, 2)
Set R = R(2, 1)
Loop
Set Dest = Dest(2, 1).EntireRow.Cells(1, "A")
Set R = R(2, 1)
Loop
End Sub

Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)

 

[Don Guillett]

Sub transposeem()
lr = Cells(Rows.Count, 1).End(xlUp).Row
p1 = 2
cr = 1
Do Until p1 >= lr
r1 = Cells(p1, 1).Row
r2 = Cells(p1, 1).End(xlDown).Row
Cells(r1, 1).Copy Cells(cr, 2)
Cells(r1 + 1, 1).Copy Cells(cr, 3)
If r2 - r1 = 3 Then
Cells(r1 + 2, 1).Copy Cells(cr, 4)
Cells(r1 + 3, 1).Copy Cells(cr, 5)
Else
Cells(r1 + 2, 1).Copy Cells(cr, 5)
End If
p1 = r2 + 2
cr = cr + 1
Loop
End Sub

 

[Mishelley]

Thank you very much for your help, Don. The code works perfectly!
Mishelley

 

[Don Guillett]

Glad to help