parsing address into separate cells

[rrands1]

I was searching for a solution, and came across a post from in 2012, and I think it is what I need, but I have a slight complication that I hope someone would be willing to help me with!

Here's the post: www.vbaexpress.com/forum/showthread.php?43188-Solved-Parsing-Addresses

My issue is that in the city where I live, it is somewhat common to not use a street type, such as ST, PL, AVE, BLVD, etc. So we have addresses like the following:


306 N SUNRISE ST MESA 85207
302 N SUNRISE MESA 85207 <--- note there is no "street type" here
262 N SUN RISE ST MESA 85207


So, when the code runs, it flags that as incorrect, even though it is a valid address

For my purposes, the city will *always* be MESA, if that helps.

Is there a way to put an empty value in the "street type" if it is not in the real address, but the word MESA is (and still fill out MESA for the City name)?


I have tried a bunch of things, but no joy yet, so I am really hoping someone can help!



Thank you so much - I really appreciate it!

[rrands1]

EDIT: in the link in my post above, see thread #6 for the code I used. I really just want something to parse out the address, though - not picky on what it is... :)

[arnelgp]

just use a simple method, Instr() to find "MESA"



Public Function GetStreet(Byval pStreet As String) As String
Const cMESA As String = " MESA"
Dim i As Integer
i = Instr(1, pStreet, cMESA)
GetStreet = pStreet
If i <> 0 Then
GetStreet = Left$(pStreet, i - 1)
End If
End Function

Public Function GetZip(Byval pStreet As String) As String
Const cMESA As String = " MESA"
Dim i As Integer
i = Instr(1, pStreet, cMESA)
If i <> 0 Then
GetZip = Trim$(Mid$(pStreet, i + Len(cMESA)))
End If
End Function

[Paul_Hossler]

You didn't say how you wanted the results or how to break it up so I made as user definded function (UDF) (I like UDFs) but the logic could be adopted to a sub

The 4 output cells need to be array entered (select the 4 cells, enter formula, and Ctrl+Shift+Enter) to add the braces (you don't type them)

29150



Option Explicit


Function ParseData(s As String) As Variant
Dim ary(1 To 4) As Variant
Dim v As Variant
Dim i As Long

v = Split(s, " ")

'zip
ary(4) = v(UBound(v))
'city
ary(3) = v(UBound(v) - 1)
'number
ary(1) = v(LBound(v))
'street
ary(2) = v(1)
For i = LBound(v) + 2 To UBound(v) - 2
ary(2) = ary(2) & " " & v(i)
Next i


ParseData = ary
End Function

[snb]

In C1

=LEFT(A1,SEARCH(" ",A1)-1)
in D1

=TRIM(MID(A1,LEN(C1)+1,SEARCH("_",SUBSTITUTE(A1," ","_",LEN(A1)-LEN(SUBSTITUTE(A1," ",""))-1))-LEN(C1)))
In E1

=RIGHT(A1,LEN(A1)-LEN(C1)-LEN(D1)-2)

[rrands1]

Thanks, all - based on some of your input, here is what I ended up with, in case it helps others. (note I have commented out some of the original code, as I don't need it for my purposes). I am by *no means* a developer, so improvements welcome, but this is working for me for now... :)



Sub Parse_Addresses()


Dim sSplitAddr() As String
Dim vPart As Variant
Dim vStreets As Variant
Dim i As Integer
Dim iFound As Integer
Dim iLocation As Integer ' element location in the array that we are working with
Dim vType As Variant
Dim validStreet As Variant
Dim sBuildAddress As String
Dim rProcessCell As Range


'This code will handle well formed addresses and split them into Number, Direction, Street, City and Zip




Set rProcessCell = Range("B2") ' select the "Property Address" column
Do While rProcessCell.Value <> ""
sSplitAddr = Split(Trim(rProcessCell.Value), " ")
If UBound(sSplitAddr) = 0 Then GoTo DontProcessFurther


'Check whether Direction is in address, if not set blank position
If Not HasDirn(sSplitAddr(1)) Then
ReDim Preserve sSplitAddr(UBound(sSplitAddr) + 1)
For i = UBound(sSplitAddr) To 2 Step -1 ' start at the last element in sSplitAddr and step backwards
sSplitAddr(i) = sSplitAddr(i - 1) ' as you step back, copy the prev element's value to current one so when you get to spot 1, you can insert blank street dir & keep all data
Next
sSplitAddr(1) = "" ' this is the blank where Direction is in other addresses
End If


' Check whether any street type suffixes are in the address
vStreets = Array("ST", "TER", "DR", "LN", "RD", "CT", "AVE", "PL")
iFound = 0


For Each vType In vStreets
iLocation = 1
For i = 3 To UBound(sSplitAddr)
If sSplitAddr(i) = vType Then
validStreet = True
iFound = i
Exit For
End If
iLocation = iLocation + 1 ' count to help us when determining if the street name has more than one word
Next i
Next
If iFound = 0 Then ' Didn't find a ST NAME for this street, so add in a blank value element for it to preserve columns in right order
If UBound(sSplitAddr) <= 4 Then ' street name *should* be a single name
ReDim Preserve sSplitAddr(UBound(sSplitAddr) + 1)
For i = UBound(sSplitAddr) To 3 Step -1 ' start at the last element in sSplitAddr and step backwards
sSplitAddr(i) = sSplitAddr(i - 1) ' as you step back, copy the prev element's value to current one so when you get to spot 3, you can insert blank ST NAME & keep all data
Next
sSplitAddr(3) = "" ' this is the blank where ST NAME is in other addresses

ElseIf UBound(sSplitAddr) >= 5 Then ' street name *likely* not a single word, so concatenate them, then add in element for ST NAME
sBuildAddress = ""
For i = 2 To iLocation - 1
sBuildAddress = sBuildAddress & " " & sSplitAddr(i)
Next i
sBuildAddress = Mid(sBuildAddress, 2, Len(sBuildAddress) - 1)
sSplitAddr(2) = sBuildAddress
For i = iLocation To UBound(sSplitAddr)
sSplitAddr(i - iLocation + 3) = sSplitAddr(i)
Next i
ReDim Preserve sSplitAddr(UBound(sSplitAddr) + 3 - iLocation)
' now add the space for ST NAME, since it still is missing
ReDim Preserve sSplitAddr(UBound(sSplitAddr) + 1)
For i = UBound(sSplitAddr) To 3 Step -1 ' start at the last element in sSplitAddr and step backwards
sSplitAddr(i) = sSplitAddr(i - 1) ' as you step back, copy the prev element's value to current one so when you get to spot 3, you can insert blank ST NAME & keep all data
Next
sSplitAddr(3) = "" ' this is the blank where ST NAME is in other addresses
End If
End If




If iFound > 3 Then 'Street *likely* has a two or more word name so combine name and contract array
sBuildAddress = ""
For i = 2 To iFound - 1
sBuildAddress = sBuildAddress & " " & sSplitAddr(i)
Next i
sBuildAddress = Mid(sBuildAddress, 2, Len(sBuildAddress) - 1)
sSplitAddr(2) = sBuildAddress
For i = iFound To UBound(sSplitAddr)
sSplitAddr(i - iFound + 3) = sSplitAddr(i)
Next i
ReDim Preserve sSplitAddr(UBound(sSplitAddr) + 3 - iFound)
End If


'check last address part for # and remove
If Left(sSplitAddr(UBound(sSplitAddr)), 1) = "#" Then
sSplitAddr(UBound(sSplitAddr)) = Right(sSplitAddr(UBound(sSplitAddr)), Len(sSplitAddr(UBound(sSplitAddr))) - 1)
End If
'check last address part for apt and remove
If Left(sSplitAddr(UBound(sSplitAddr)), 3) = "APT" Then
sSplitAddr(UBound(sSplitAddr)) = Right(sSplitAddr(UBound(sSplitAddr)), Len(sSplitAddr(UBound(sSplitAddr))) - 3)
End If


DontProcessFurther:
rProcessCell.Offset(0, 1).Resize(, UBound(sSplitAddr) + 1).Value = sSplitAddr
'check for badly formed address
' ' commenting out this call to highlight malformed addresses as a test '' Highlight_Bad_Addresses rProcessCell, vStreets
Set rProcessCell = rProcessCell.Offset(1, 0)
Loop
End Sub


Function HasDirn(checkDirn As String)


Dim test As Variant
HasDirn = False
Dim sDirn() As Variant


sDirn = Array("N", "NE", "NW", "S", "SE", "SW", "W", "E")
For Each test In sDirn
If checkDirn = test Then HasDirn = True
Next


End Function


' Sub Highlight_Bad_Addresses(rProcessCell As Range, vStreets As Variant)
' 'if Column E doesn't contain a valid street type it will be considered
' ' to be a badly formed address and highlihgted for manual attention
' Range(rProcessCell.Offset(0, 1), rProcessCell.Offset(0, 7)).Interior.ColorIndex = 0
' If UBound(Filter(vStreets, rProcessCell.Offset(0, 4).Value)) < 0 Or rProcessCell.Offset(0, 4).Value = "" Then
' Range(rProcessCell.Offset(0, 1), rProcessCell.Offset(0, 7)).Interior.ColorIndex = 3
' End If

' End Sub