Need help transposing mailing list

[rkohlbeck]

Hello, I'm new to excel so bear with me.

I have a list like this:

John Doe
1234 Happy St
Anywhere, NC 11111
123-123-1234

Happy Guy
4321 Sad St
PO Box 12
Nowhere, WI 55555
321-321-4321

They are all in column A (2000 rows). There is a blank row before each new info section. So what I need is this list in columns.
Column A = Name
Column B = Street Address
Column C = Mailing Address

And so on. I've tried a few things, but I just can't get it all the way.

Thanks!

 

[Henry]

PuP will fix it--guaranteed. I think I paid $60 or so.

Besides that Transpose thing (go to Range inl the menu), it's got a bunch of neat things I used all the time. I'm surprised MS hasn't jumped on their band wagon and updated there version. Again, you can use if for a while (free trial period). If you get stuck (almost impossible) loading the Add-In, let me know. You'll flip when you see this thing in action. I think it was made by that John Walkenbach guy or something like that. Let me know what you do--just curious.

Henry

 

[AJ]

Hi Ryan,
On having had a look at the file you sent, the reason things weren't quite working was variable "entries" in the "blank" rows. Some had nothing in, some had a single space and others had a double space. Changing my last code to allow for this, we have...

Sub Thirdattempt()

Dim LastRow As Integer
Dim PasteRow As Integer

' Set PasteRow
PasteRow = 1
' Data starts in Cell A1
Range("A1").Select
' Start Loop
Do While ActiveCell.Value <> Empty
' Go down current address and find out where it ends (looking for a cell with a space)
Do While ActiveCell.Value <> " " And ActiveCell.Value <> " " And ActiveCell.Value <> Empty
ActiveCell.Offset(1, 0).Select
LastRow = ActiveCell.Row
Loop
' N.B. LastRow is now actually the blank row
' Copy the current selection
Range("A1:A" & LastRow - 1).Select
Selection.Copy
' Select where to paste
Range("B" & PasteRow).Select
' Paste
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
' Delete the first address
Range("A1:A" & LastRow).Select
Selection.Delete Shift:=xlUp
' Increase Pasterow by 1
PasteRow = PasteRow + 1
' Start again
Range("A1").Select
Loop
' Delete Column A because it's now empty
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

End Sub

Which now works!
Rgds
AJ