Parse Adress into seperate columns

[danpotash]

Can someone be so kind to help me with building a macro for my issue I am trying to split address elements in separate columns some of the addresses have zip codes some do not some have country name some do not below is the format of the data that I have I would like to separate it into address city state zip and country [TABLE="width: 452"]
<tbody>[TR]
[TD]42 CHARLES DR RICHBORO PA 18954[/TD]
[/TR]
[TR]
[TD]130 E 72NO ST APT 4 NEW YORK NY 10021[/TD]
[/TR]
[TR]
[TD]205 OSERAVE HAUPPAUGE NY 11788[/TD]
[/TR]
[TR]
[TD]77 Northeastern BLVD NASHUA NH 3062[/TD]
[/TR]
[TR]
[TD]3900 GREEN OAK OR WACO TX 76710[/TD]
[/TR]
[TR]
[TD]11303 VIEW HIGH DR KANSAS CitY MO 64134 us[/TD]
[/TR]
[TR]
[TD]6070 GlJLFPbRt BLVD 5 ST PETERSBURG FL 33707 us[/TD]
[/TR]
[TR]
[TD]600 Delzan PI LEXINGTON KY 40503 us[/TD]
[/TR]
[TR]
[TD]180 E END AVE APT 4B NEW YORK CITY NY 10128[/TD]
[/TR]
[TR]
[TD]3 RIVERWAY STE 1800 HOUSTON TX 77056[/TD]
[/TR]
[TR]
[TD]15117 Illinois Avenue PARAMOUNT CA 90723[/TD]
[/TR]
[TR]
[TD]6700 Guadalupe Street AUSTIN TX 78752[/TD]
[/TR]
[TR]
[TD]179 GLEN RD CHAGRIN FALLS OH 44022[/TD]
[/TR]
[TR]
[TD]790 IVANHOE ST DENVER co 80220 us[/TD]
[/TR]
[TR]
[TD]60 East 42nd Street NEW YORK NY 10165[/TD]
[/TR]
[TR]
[TD]550 S HILL STREET LOS ANGELES CA 90013[/TD]
[/TR]
[TR]
[TD]179 WALLABOUT ST BROOKLYN NY 11206[/TD]
[/TR]
[TR]
[TD]1100 E Main Sl MORRISTOWN TN 37814[/TD]
[/TR]
[TR]
[TD]150 S Wacker Drive Ste 450 CHICAGO IL 60606[/TD]
[/TR]
[TR]
[TD]2970 MARKET ST PHILADELPHIA PA 19104 us[/TD]
[/TR]
[TR]
[TD]8301 S CASS AVE STE 203 DARIEN IL 60561[/TD]
[/TR]
[TR]
[TD]10580 JUSTIN DR URBANDALE lA [/TD]
[/TR]
[TR]
[TD]200 MOTOR PKWY HAUPPAUGE NY 11788[/TD]
[/TR]
[TR]
[TD]2040 N 91st St LINCOLN NE 68505 us[/TD]
[/TR]
[TR]
[TD]1006 BROWN ST PEEKSKILL NY 10566[/TD]
[/TR]
[TR]
[TD]514 BETHJ\NY CIR MURFREESBORO TN 37128 us[/TD]
[/TR]
[TR]
[TD]1400 S VANDEVENTER AVENUE ST. LOUIS MO 63110[/TD]
[/TR]
[TR]
[TD]26052 COLMAN DR WARREN Ml 48091 us[/TD]
[/TR]
[TR]
[TD]1225 MERIDIAN ST N HUNTSVILLE AL 35801[/TD]
[/TR]
[TR]
[TD]1700 Boardwalk WILDWOOD NJ 8260 us[/TD]
[/TR]
[TR]
[TD]350 5TH AVE STE 7413 NEW YORK CITY NY 10118 us[/TD]
[/TR]
[TR]
[TD]14 WALL ST 2RD FL NEW YORK CITY NY 10005 us[/TD]
[/TR]
[TR]
[TD]4195 SERPENTINE WAY MASON OH 45040[/TD]
[/TR]
[TR]
[TD]15543 VALERIO ST VAN NUYS CA 91406 us[/TD]
[/TR]
[TR]
[TD]15543 VALERIO ST VAN NUYS CA 91406 us[/TD]
[/TR]
[TR]
[TD]3235 Pole Line Road POCATELLO ID 83201[/TD]
[/TR]
[TR]
[TD]160 27th Street BROOKLYN NY 11232[/TD]
[/TR]
[TR]
[TD]206 Minden Rd MINDEN wv 25B79 US[/TD]
[/TR]
[TR]
[TD]710 S 4th Street LAMAR co 81052[/TD]
[/TR]
[TR]
[TD]100 E PEARL ST H.t1RRISONVILLE MO 64701 us[/TD]
[/TR]
</tbody><colgroup><col></colgroup>[/TABLE]

 

[mikerickson]

Addresses are so very idiocyncratic that a general algorithm won't work. The best help that I can offer is these routines that will move a word one cell to the right (with a right click) or the left (with a double click) to help tidy up after trying an alorythm.

You could use TextToColumns with a space delimiter and then Double click on cells until everything is in nice columns.

let me add one more possible address
23 1/2 Smith St. St. Croix IL

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Words As Variant
    With Target
        If 1 < .Column Then
            Words = Split(CStr(.Value), " ")
            If 0 <= UBound(Words) Then
                
                .Offset(0, -1).Value = Application.Trim(.Offset(0, -1).Value & " " & Words(0))
                .Value = Application.Trim(Replace(CStr(.Value), Words(0), vbNullString, , 1))
            End If
            
        End If
        Cancel = True
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim Words As Variant
    Cancel = True
    With Target
        Words = Split(CStr(.Value), " ")
        If -1 < UBound(Words) Then
            .Offset(0, 1).Value = Application.Trim(Words(UBound(Words)) & " " & .Offset(0, 1).Value)
            If UBound(Words) = 0 Then
                .Value = vbNullString
            Else
                ReDim Preserve Words(0 To UBound(Words) - 1)
                .Value = Join(Words, " ")
            End If
        End If
    End With
End Sub