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