Parse Address

[Ajw43022]

Hi, I'm trying to make a macro that does the following:

Parses an address inside a cell to the following fields to the right of that cell:

First Name
Last Name
Street
City
State
Zip
Country

(really I'd like it to do this for ALL cells I've got selected, so it can do multiple addresses at once)

The tricky part is that there's some variation in the format of the address. Here are all variations:

Michael Green
517 W111st St
New York, NY 10032
United States

Michael Green
517 W111st St
Apt 15 (where address line 2 exists, I want the Street field to equal Address Line 1 [carriage return] Address line 2)
New York, NY 10032
United States

Michael Green
517 W111st St
Apt 15
New York, NY
10032 (sometimes the zip code is on the next line from city, state)
United States

Not quite sure how to write the parser, and be able to handle these variations. Any help would be greatly appreciated. thank you!

 

[BrianB]

This works on the data you supplied :

'==============================================================================
'- PARSE SINGLE CELL CONTENTS TO COLUMNS
'- Assumes that source cells are wrapped with Alt+Enter used to separate lines
'- Alt+Enter adds non-printing character code 10 (LineFeed)
'- Brian Baulsom December 2009
'==============================================================================
Dim First As Integer
Dim Last As Integer
Dim Street As Integer
Dim City As Integer
Dim State As Integer
Dim Zip As Integer
Dim Country As Integer
'-
Dim ws As Worksheet
Dim MyRow As Long
Dim MyColumn As Integer
Dim LastRow As Long
Dim CellText As Variant
Dim EndLine As String           ' linefeed character
Dim MyLine As Integer           ' each line of text in the cell
Dim LineText As String          ' line text string
Dim LineCount As Integer        ' line counter
Dim sp As Integer               ' space or comma position
Dim StateZip As String
Dim ItemFound As Integer        ' data item number
'==============================================================================
'- MAIN ROUTINE
'==============================================================================
Sub CELL_TO_COLUMNS()
    Set ws = ActiveSheet
    LastRow = ws.Range("A65536").End(xlUp).Row
    'ws.Range("B2:H" & LastRow).ClearContents  ' FOR TESTING
    EndLine = vbLf          ' linefeed character 10
    '------------------------------------------------
    '- TARGET COLUMNS
    First = 2       ' item 1
    Last = 3
    Street = 4
    City = 5
    State = 6
    Zip = 7
    Country = 8     ' item 7
    '==========================================================================
    '- MAIN LOOP - each row of worksheet
    '==========================================================================
    For MyRow = 2 To LastRow
        CellText = Split(ws.Cells(MyRow, 1).Value, EndLine)
        ItemFound = 0
        '======================================================================
        '- LOOP 2 : EXAMINE EACH LINE OF TEXT IN THE CELL
        '======================================================================
        LineCount = UBound(CellText)
        For MyLine = 0 To LineCount
            LineText = Trim(CellText(MyLine))
            '==================================================================
            '- 1st. & 2nd. items = First & Last Names
            '==================================================================
            If ItemFound = 0 Then
                sp = InStr(1, LineText, " ", vbTextCompare) ' find first SPACE
                If sp > 0 Then
                    ws.Cells(MyRow, First).Value = Left(LineText, sp - 1)
                    ws.Cells(MyRow, Last).Value = Right(LineText, Len(LineText) - sp)
                Else
                    ws.Cells(MyRow, First).Value = LineText
                End If
                '=============
                ItemFound = 2
                '=============
            '==================================================================
            '- 3rd. Item = Street
            '==================================================================
            ElseIf ItemFound = 2 Then
                     ws.Cells(MyRow, Street).Value = LineText
                    '=============
                     ItemFound = 3
                    '=============
            '==================================================================
            '- could be address 1 or Items 4/5/6 = City/State/Zip
            '- look for comma to decide
            '==================================================================
            ElseIf ItemFound = 3 Then
                sp = InStr(1, LineText, ",", vbTextCompare) ' find COMMA
                If sp = 0 Then      ' NO COMMA - add to Street cell
                     ws.Cells(MyRow, Street).Value = _
                        LineText & " " & ws.Cells(MyRow, Street).Value
                Else
                    '- Item 4 = CITY
                    ws.Cells(MyRow, City).Value = Left(LineText, sp - 1)
                    '=============
                    ItemFound = 4
                    '=============
                    '=========================================================
                    '- Item 5 = STATE & Item 6 = ZIP
                    StateZip = Right(LineText, Len(LineText) - sp - 1)
                    sp = InStr(1, StateZip, " ", vbTextCompare) ' find SPACE
                    If sp > 0 Then
                        ws.Cells(MyRow, State).Value = Left(StateZip, sp - 1)
                        ws.Cells(MyRow, Zip).Value = Right(StateZip, Len(StateZip) - sp)
                        '=============
                        ItemFound = 6
                        '=============
                    Else
                        ws.Cells(MyRow, State).Value = CStr(StateZip)
                        '=============
                        ItemFound = 5
                        '=============
                    End If
                End If
            '==================================================================
            '- Could be Item 6 = Zip or Item 7 = Country
            '- check if a number
            '==================================================================
            ElseIf ItemFound = 5 Then
                If IsNumeric(LineText) Then
                    ws.Cells(MyRow, Zip).Value = LineText
                    '==============
                    ItemFound = 6
                    '==============
                Else
                    ws.Cells(MyRow, Country).Value = LineText
                    '=============
                    ItemFound = 7
                    '=============
                End If
            '==================================================================
            '- Item 7 = Country
            '==================================================================
            ElseIf ItemFound = 6 Then
                ws.Cells(MyRow, Country).Value = LineText
            End If
            '==================================================================
        Next MyLine
        '---------------------------------------------------------------------
    Next MyRow
    '--------------------------------------------------------------------------
    MsgBox ("Done")
End Sub
'==============================================================================

 

[Ajw43022]

thank you!