formula help for data relocating

[zandbdad]

I have a poor soul that wasted alot of time exporting a rich text doc (11,500 addresses) that he needs to convert into an excel doc (to eventually make labels). I helped him import the rich text into excel but I will need help from here. We need to convert a running list (in column A) of contact info into your average address contact list format. The list runs in a pattern down column A like this:

Mike sample
9002 Gargs drive
columbus, ohio 43212

Barry Swidel
102 kirk place
columbus, ohio 43215

etc...

Since it is a similar pattern is there a way to run a formula to extract the info in A1 (plus every fourth cell) and put it in Column B (which would become the name column). Then A2 (plus every fourth cell) into Column C (as the street column) and so on so it would completely reformat the list for me.

He has spent alot of time on this and I thought I could help (with your help) bail him out.

Thanks ahead of time. This site is fantastic.

 

[VoG]

Try this. Press ALT + F11 to open the Visual Basic Editor, Insert > Module and paste in

Sub reorder()
Dim ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, k As Integer, LR As Long
Set ws1 = ActiveSheet
Set ws2 = Worksheets.Add
j = 1
With ws1
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        If .Range("A" & i).Value = "" Then
            j = j + 1
            k = 0
        Else
            k = k + 1
            ws2.Cells(j, k).Value = .Range("A" & i).Value
        End If
    Next i
End With
End Sub

Press ALT + F11 to return to your sheet, Tools > Macro > Macros, highlight reorder and click the Run button.

 

[zandbdad]

It relocated them but now they run horizontal across row 1. I debugged it and said the problem was in the line:
ws2.Cells(j, k).Value = .Range("A" & i).Value

Did I leave something out in my description that is causing a problem.

like that the address run down column A but each piece of info is in a separate row.

Mike Sowders (A1)
9020 Likes street (A2)
Columbus, ohio 43212 (A3)
(A4)
Jerry Gus (A5)
345 Level Street (A6)
Grandview, Ohio 43212 (A7)

 

[VoG]

Perhaps A4 isn't blank but contains spaces. Try

Sub reorder()
Dim ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, k As Integer, LR As Long
Set ws1 = ActiveSheet
Set ws2 = Worksheets.Add
j = 1
With ws1
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        If .Range("A" & i).Value = "" Or .Range("A" & i).Value Like " *" Then
            j = j + 1
            k = 0
        Else
            k = k + 1
            ws2.Cells(j, k).Value = .Range("A" & i).Value
        End If
    Next i
End With
End Sub

 

[zandbdad]

You are probably right. Now when I ran it, it left a blank sheet. Any other ideas?

Thanks for your time!!!

 

[VoG]

Enter this in a spare cell

=CODE(A4)

what does it return?

 

[zandbdad]

if I paste it in in reads as ####, if I type it above it reads as: #value, an error. Does this tell you anything?

 

[VoG]

if I paste it in in reads as ####, if I type it above it reads as: #value, an error. Does this tell you anything?

It tells me that there's something weird going on. Please make a copy of, say, 20 rows of data, change the names etc to protect the innocent (don't touch the 'blank' cells), upload it to www.box.net and post a link to it here.

 

[zandbdad]

Thanks again for your help. Here is the link:

http://www.box.net/shared/a0rxrnflfg

Let me know if you can resolve it. I greatly appreciate it.

 

[VoG]

Some of the 'blanks' in column A actually contained spaces but also some of the address lines began with spaces. This worked on the sample data:

Sub reorder()
Dim ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, k As Integer, LR As Long
Set ws1 = ActiveSheet
Set ws2 = Worksheets.Add
j = 1
With ws1
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("A" & i)
            .Value = Trim(.Value)
            If .Value = "" Then
                j = j + 1
                k = 0
            Else
                k = k + 1
                ws2.Cells(j, k).Value = .Value
            End If
        End With
    Next i
End With
End Sub