Solved

Address Scrubber

Posted on 2006-07-07
2
358 Views
Last Modified: 2012-06-21
Hello:

Do any of you know if there is a vb or vba routine out there I can use to standardize an address to postal standards?  For instance, something that would make P O Box, P.O. Box, Post Office Box, and Box all read PO Box?  

The routine doesn't necessarily need to be in vb or vba.  I could use another language and just modify it for vb.

Thanks,
David Creswell
0
Comment
Question by:davidandreacreswell
2 Comments
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 17061882
Hi David,

You could use Regular Expressions to do this.  Here is a function:

' Function by Patrick Matthews

Option Explicit

Function RegExpReplace(LookIn As String, PatternStr As String, Optional ReplaceWith As String = "", _
    Optional ReplaceAll As Boolean = True, Optional MatchCase As Boolean = True)

    ' This function uses Regular Expressions to parse a string, and replace parts of the string
    ' matching the specified pattern with another string.  The optional argument ReplaceAll controls
    ' whether all instances of the matched string are replaced (True) or just the first instance (False)
   
    ' By default, RegExp is case-sensitive in pattern-matching.  To keep this, omit MatchCase or
    ' set it to True
   
    ' If you use this function from Excel, you may substitute range references for all the arguments
   
    Dim RegX As Object
   
    Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Pattern = PatternStr
        .Global = ReplaceAll
        .IgnoreCase = Not MatchCase
    End With
   
    RegExpReplace = RegX.Replace(LookIn, ReplaceWith)
   
    Set RegX = Nothing
   
End Function



Now you could use it like this:

SomeVar = RegExpReplace(SomeVar, "(P(\.| |ost){0,1}){0,1} {0,1}(O(\.| |ffice){0,1}){0,1} {0,1}Box", "PO Box", False, False)

There could be an easier pattern string out there; I went with a brute force approach...

Regards,

Patrick
0
 
LVL 13

Accepted Solution

by:
jmundsack earned 500 total points
ID: 17061969
*** begin class ***

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Address"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'---------------------------------------------------------------------
'
' Copyright ©2003 Jon A. Mundsack
' All Rights Reserved
'
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
'
'---------------------------------------------------------------------

Option Explicit

Private mOriginal As String
Private mHouseNumber As String
Private mPredirectional As String
Private mStreetName As String
Private mStreetType As String
Private mPostDirectional As String
Private mExtras As String
Private mTranslations() As TTranslation

Private Type TTranslation
    Abbreviated As String
    Expanded As String
End Type

Private Function Abbreviate(ByRef Segment As String) As String
    On Error GoTo Handler
    Dim i As Integer
    For i = LBound(mTranslations) To UBound(mTranslations)
        If Segment = mTranslations(i).Expanded Then
            Abbreviate = mTranslations(i).Abbreviated
            Exit Function
        End If
    Next i
    Abbreviate = Segment
    Exit Function
Handler:
    Abbreviate = Segment
End Function

Private Function Expand(ByRef Segment As String) As String
    On Error GoTo Handler
    Dim i As Integer
    For i = LBound(mTranslations) To UBound(mTranslations)
        If Segment = mTranslations(i).Abbreviated Then
            Expand = mTranslations(i).Expanded
            Exit Function
        End If
    Next i
    Expand = Segment
    Exit Function
Handler:
    Expand = Segment
End Function

' This function was downloaded from somewhere on the web.
' No identification of the author nor any mention of a
' copyright or license was specified in the code so I
' presume it to be public domain.
Public Function ConvertNumberToText(vstrNumber As String) As String
    Dim strNumber           As String
    Dim strCluster          As String
    Dim strNumberAsText     As String
    Dim strTempNumber       As String
    Dim strTemp             As String
    Dim strPosition         As String
    Dim blnDone             As Boolean
    Dim intPosition         As Integer
    Dim aryPosition(101)    As String
    Dim aryPrefix(9)        As String
    Dim aryBody(10)         As String
    strNumber = vstrNumber
    strNumber = Replace(strNumber, ",", "")
    For intPosition = 1 To Len(strNumber)
        If (Asc(Mid(strNumber, intPosition, 1)) < 48) Or (Asc(Mid(strNumber, intPosition, 1)) > 57) Then
            ConvertNumberToText = vstrNumber
            Exit Function
        End If
    Next intPosition
    aryPrefix(1) = " "
    aryPrefix(2) = " UN"
    aryPrefix(3) = " DUO"
    aryPrefix(4) = " TRE"
    aryPrefix(5) = " QUATTUOR"
    aryPrefix(6) = " QUIN"
    aryPrefix(7) = " SEX"
    aryPrefix(8) = " SEPTEN"
    aryPrefix(9) = " OCTO"
    aryPrefix(0) = " NOVEM"
    aryBody(1) = "DECILLION "           '---From 10^33 to 10^60
    aryBody(2) = "VIGINTILLION "        '---From 10^63 to 10^90
    aryBody(3) = "TRIGINTILLION "       '---From 10^93 to 10^120
    aryBody(4) = "QUADRAGINTILLION "    '---From 10^123 to 10^150
    aryBody(5) = "QUINQUAGINTILLION "   '---From 10^153 to 10^180
    aryBody(6) = "SEXUAGINTILLION "     '---From 10^183 to 10^210
    aryBody(7) = "SEPTUAGINTILLION "    '---From 10^213 to 10^240
    aryBody(8) = "OCTOGINTILLION "      '---From 10^243 to 10^270
    aryBody(9) = "NONAGINTILLION "      '---From 10^273 to 10^300
    aryBody(10) = "CENTILLION "         '---From 10^303 to 10^333
    aryPosition(0) = ""
    aryPosition(1) = " THOUSAND "
    aryPosition(2) = " MILLION "
    aryPosition(3) = " BILLION "
    aryPosition(4) = " TRILLION "
    aryPosition(5) = " QUADRILLION "
    aryPosition(6) = " QUINTILLION "
    aryPosition(7) = " SEXTILLION "
    aryPosition(8) = " SEPTILLION "
    aryPosition(9) = " OCTILLION "
    aryPosition(10) = " NONTILLION "
    For intPosition = 11 To 101
        If (intPosition - 1) = (intPosition \ 10) * 10 Then
            aryPosition(intPosition) = aryPrefix(intPosition Mod 10) & aryBody(Int(intPosition / 10))
        Else
            aryPosition(intPosition) = aryPrefix(intPosition Mod 10) & LCase(aryBody(Int(intPosition / 11)))
        End If
    Next intPosition
    strPosition = ""
    strNumberAsText = ""
    strNumber = StrReverse(strNumber)
    blnDone = False
    intPosition = 0
    Do While Not blnDone
        strCluster = StrReverse(Mid(strNumber, 1, 3))
        strTempNumber = ""
        If (Len(strNumber) - 3) < 1 Then
            blnDone = True
        Else
            strNumber = Mid(strNumber, 4)
        End If
        Do While Len(strCluster) < 3
            strCluster = "0" & strCluster
        Loop
        strTemp = GetTextNumber(Val(Left(strCluster, 1)))
        If Len(strTemp) > 0 Then strTempNumber = strTemp & " Hundred "
        strTemp = GetTextNumber(Val(Mid(strCluster, 2, 2)))
        If Len(strTemp) = 0 Then
            strTemp = GetTextNumber(Val(Mid(strCluster, 2, 1)) * 10)
            strTempNumber = strTempNumber & strTemp
            strTemp = GetTextNumber(Val(Mid(strCluster, 3, 1)))
            If Len(strTemp) > 0 Then
                strTempNumber = strTempNumber & " " & strTemp
            End If
        Else
            strTempNumber = strTempNumber & strTemp
        End If
        If Len(strTempNumber) + 0 Then strNumberAsText = strTempNumber & aryPosition(intPosition) & strNumberAsText
        intPosition = intPosition + 1
    Loop
    ConvertNumberToText = strNumberAsText
End Function

' This function was downloaded from somewhere on the web.
' No identification of the author nor any mention of a
' copyright or license was specified in the code so I
' presume it to be public domain.
Private Function GetTextNumber(intNumber As Integer) As String
    Select Case intNumber
        Case 0: GetTextNumber = ""
        Case 1: GetTextNumber = "ONE"
        Case 2: GetTextNumber = "TWO"
        Case 3: GetTextNumber = "THREE"
        Case 4: GetTextNumber = "FOUR"
        Case 5: GetTextNumber = "FIVE"
        Case 6: GetTextNumber = "SIX"
        Case 7: GetTextNumber = "SEVEN"
        Case 8: GetTextNumber = "EIGHT"
        Case 9: GetTextNumber = "NINE"
        Case 10: GetTextNumber = "TEN"
        Case 11: GetTextNumber = "ELEVEN"
        Case 12: GetTextNumber = "TWELVE"
        Case 13: GetTextNumber = "THIRTEEN"
        Case 14: GetTextNumber = "FOURTEEN"
        Case 15: GetTextNumber = "FIFTEEN"
        Case 16: GetTextNumber = "SIXTEEN"
        Case 17: GetTextNumber = "SEVENTEEN"
        Case 18: GetTextNumber = "EIGHTEEN"
        Case 19: GetTextNumber = "NINETEEN"
        Case 20: GetTextNumber = "TWENTY"
        Case 30: GetTextNumber = "THIRTY"
        Case 40: GetTextNumber = "FORTY"
        Case 50: GetTextNumber = "FIFTY"
        Case 60: GetTextNumber = "SIXTY"
        Case 70: GetTextNumber = "SEVENTY"
        Case 80: GetTextNumber = "EIGHTY"
        Case 90: GetTextNumber = "NINETY"
    End Select
End Function

Private Function ConvertNumberToAdjective(ByVal Number As String) As String
    Select Case Number
        Case "ONE": ConvertNumberToAdjective = "FIRST"
        Case "TWO": ConvertNumberToAdjective = "SECOND"
        Case "THREE": ConvertNumberToAdjective = "THIRD"
        Case "FOUR": ConvertNumberToAdjective = "FOURTH"
        Case "FIVE": ConvertNumberToAdjective = "FIFTH"
        Case "SIX": ConvertNumberToAdjective = "SIXTH"
        Case "SEVEN": ConvertNumberToAdjective = "SEVENTH"
        Case "EIGHT": ConvertNumberToAdjective = "EIGHTH"
        Case "NINE": ConvertNumberToAdjective = "NINTH"
        Case "TEN": ConvertNumberToAdjective = "TENTH"
        Case "ELEVEN": ConvertNumberToAdjective = "ELEVENTH"
        Case "TWELVE": ConvertNumberToAdjective = "TWELFTH"
        Case "TWENTY", "THIRTY", "FORTY", "FIFTY", "SIXTY", "SEVENTY", "EIGHTY", "NINETY"
            ConvertNumberToAdjective = Left$(Number, Len(Number) - 1) & "IETH"
        Case Else: ConvertNumberToAdjective = Number & "TH"
    End Select
End Function

Private Function NumberWords(ByVal Segment As String)
    On Error GoTo Handler
    Dim strTemp As String
    Dim strResult As String
    Dim strParts() As String
    Dim intPart As Integer
    strTemp = Segment
    strTemp = UCase$(Trim$(strTemp))
    If IsNumeric(Left$(strTemp, Len(strTemp) - 2)) And (InStr("ST,ND,RD,TH", Right$(strTemp, 2))) Then
        strTemp = UCase$(Trim$(ConvertNumberToText(Left$(strTemp, Len(strTemp) - 2))))
        strParts = Split(strTemp, " ")
        For intPart = LBound(strParts) To (UBound(strParts) - 1)
            If strResult <> "" Then strResult = strResult & " "
            strResult = strResult & strParts(intPart)
        Next intPart
        If strResult <> "" Then strResult = strResult & "-"
        strResult = strResult & ConvertNumberToAdjective(strParts(UBound(strParts)))
        NumberWords = strResult
    Else
        NumberWords = Segment
    End If
    Exit Function
Handler:
    NumberWords = Segment
End Function

Public Sub SplitAddress(ByVal Original As String)
    On Error GoTo Handler
    Dim segments() As String
    Dim strTemp As String
    Dim i As Long
    Dim j As Long
    Dim Modified As String
    Dim dirstrnam As Boolean
    mOriginal = Original
    Modified = Original
    mHouseNumber = ""
    mPredirectional = ""
    mStreetName = ""
    mStreetType = ""
    mPostDirectional = ""
    mExtras = ""
    Modified = UCase(Trim(Modified))
    'get rid of (most) punctuation
    Modified = Replace(Modified, ",", " ")
    Modified = Replace(Modified, ".", "")
    Modified = Replace(Modified, ":", "")
    Modified = Replace(Modified, ";", "")
    'handle variations on APARTMENT
    Modified = Replace(Modified, "APARTMENTS", "APTS")
    Modified = Replace(Modified, "APARTMENT", "APT")
    Modified = Replace(Modified, "APT #", "APT ")
    Modified = Replace(Modified, "APT# ", "APT ")
    Modified = Replace(Modified, "APT#", "APT ")
    Modified = Replace(Modified, "# ", "APT ")
    Modified = Replace(Modified, "#", "APT ")
    'handle variations on ROOM
    Modified = Replace(Modified, "ROOM", "RM")
    Modified = Replace(Modified, "RM #", "RM ")
    Modified = Replace(Modified, "RM# ", "RM ")
    Modified = Replace(Modified, "RM#", "RM ")
    'handle variations on PO BOX
    Modified = Replace(Modified, "POBOX", "PO BOX", , , vbTextCompare)
    Modified = Replace(Modified, "P O BOX", "PO BOX", , , vbTextCompare)
    'now process the address segments
    segments = Split(Modified, " ")
    If UBound(segments) < 0 Then Exit Sub
    For i = LBound(segments) To UBound(segments)
        segments(i) = NumberWords(segments(i))
        segments(i) = Abbreviate(segments(i))
    Next i
    i = LBound(segments)
    Do
        Select Case segments(i)
            Case "APT", "RM", "STE"
                If mExtras <> "" Then mExtras = mExtras & " "
                If i < UBound(segments) Then
                    mExtras = mExtras & segments(i) & " " & segments(i + 1)
                    i = i + 1
                End If
            Case "ALY", "AVE", "BLVD", "CYN", "CTR", "CIR", "CT", "XING", "DR", "HWY", "JCT", "LN", "PK", "PKWY", "PL", "PLZ", "PT", "RD", "RTE", "TER", "TR", "WY"
                If (dirstrnam) And (mStreetName = "") Then
                    If (segments(i) = "AVE") And (i < UBound(segments)) Then
                        dirstrnam = False
                    Else
                        dirstrnam = False
                        mStreetName = Expand(mPredirectional)
                        mPredirectional = ""
                    End If
                End If
                If mHouseNumber <> "" Then
                    If mStreetName = "" Then
                        mStreetName = Expand(segments(i))
                    ElseIf StreetType = "" Then
                        mStreetType = segments(i)
                    Else
                        If mExtras <> "" Then mExtras = mExtras & " "
                        mExtras = mExtras & segments(i)
                    End If
                Else
                    If mExtras <> "" Then mExtras = mExtras & " "
                    mExtras = mExtras & segments(i)
                End If
            Case "ST"
                If (dirstrnam) And (mStreetName = "") Then
                    dirstrnam = False
                    mStreetName = Expand(mPredirectional)
                    mPredirectional = ""
                End If
                If mStreetName = "" Then
                    mStreetName = "ST"
                ElseIf mStreetType = "" Then
                    mStreetType = segments(i)
                Else
                    If mExtras <> "" Then mExtras = mExtras & " "
                    mExtras = mExtras & segments(i)
                End If
            Case "PO"
                strTemp = ""
                If i < UBound(segments) Then
                    If segments(i + 1) = "BOX" Then
                        If i + 2 <= UBound(segments) Then
                            strTemp = "PO BOX " & segments(i + 2)
                            i = i + 2
                        Else
                            strTemp = "PO BOX"
                            i = i + 1
                        End If
                    End If
                End If
                If (strTemp <> "") And (mHouseNumber = "") Then
                    mHouseNumber = strTemp
                Else
                    If strTemp = "" Then strTemp = segments(i)
                    If mExtras <> "" Then mExtras = mExtras & " "
                    mExtras = mExtras & strTemp
                End If
            Case "N", "S", "E", "W", "NE", "SE", "NW", "SW"
                If mStreetName = "" Then
                    mPredirectional = segments(i)
                    dirstrnam = (i < UBound(segments))
                    If dirstrnam Then
                        Select Case segments(i + 1)
                            Case "N", "S", "E", "W", "NE", "SE", "NW", "SW"
                                dirstrnam = False
                                mStreetName = Expand(segments(i + 1))
                                i = i + 1
                        End Select
                    End If
                Else
                    mPostDirectional = segments(i)
                End If
            Case Else
                If IsNumeric(Left$(segments(i), 1)) And (mHouseNumber = "") Then
                    mHouseNumber = segments(i)
                    If i < UBound(segments) Then
                        If segments(i + 1) = "1/2" Then
                            mHouseNumber = mHouseNumber & " " & segments(i + 1)
                            i = i + 1
                        End If
                    End If
                ElseIf (mHouseNumber <> "") And (mStreetType = "") Then
                    If Len(segments(i)) = 1 And mStreetName = "" Then
                        mHouseNumber = mHouseNumber & " " & segments(i)
                    Else
                        If mStreetName <> "" Then mStreetName = mStreetName & " "
                        mStreetName = mStreetName & segments(i)
                    End If
                Else
                    If mExtras <> "" Then mExtras = mExtras & " "
                    mExtras = mExtras & segments(i)
                End If
        End Select
        i = i + 1
    Loop Until i > UBound(segments)
    Exit Sub
Handler:
    Err.Raise vbObjectError + 1001, "Address", "Error in SplitAddress method: " & Err.Description & " (" & Err.Number & ")"
End Sub

Public Property Get Original() As String
    Original = mOriginal
End Property

Public Property Get HouseNumber() As String
    HouseNumber = mHouseNumber
End Property

Public Property Get Predirectional() As String
    Predirectional = mPredirectional
End Property

Public Property Get StreetName() As String
    StreetName = mStreetName
End Property

Public Property Get StreetType() As String
    StreetType = mStreetType
End Property

Public Property Get Postdirectional() As String
    Postdirectional = mPostDirectional
End Property

Public Property Get Extras() As String
    Extras = mExtras
End Property

Public Property Get Derived() As String
    Dim result As String
    result = mHouseNumber
    If mPredirectional <> "" Then result = result & " " & mPredirectional
    If mStreetName <> "" Then result = result & " " & mStreetName
    If mStreetType <> "" Then result = result & " " & mStreetType
    If mPostDirectional <> "" Then result = result & " " & mPostDirectional
    If mExtras <> "" Then result = result & " " & mExtras
    Derived = result
End Property

Private Sub AddTranslation(ByRef Expanded As String, ByRef Abbreviated As String)
    ReDim Preserve mTranslations(UBound(mTranslations) + 1) As TTranslation
    With mTranslations(UBound(mTranslations))
        .Abbreviated = Abbreviated
        .Expanded = Expanded
    End With
End Sub

Private Sub Class_Initialize()
    ReDim mTranslations(0) As TTranslation
    Call AddTranslation("ALLEY", "ALY")
    Call AddTranslation("AVENUE", "AVE")
    Call AddTranslation("AV", "AVE")
    Call AddTranslation("BOULEVARD", "BLVD")
    Call AddTranslation("CANYON", "CYN")
    Call AddTranslation("CENTER", "CTR")
    Call AddTranslation("CNTR", "CTR")
    Call AddTranslation("CIRCLE", "CIR")
    Call AddTranslation("COURT", "CT")
    Call AddTranslation("CRT", "CT")
    Call AddTranslation("CROSSING", "XING")
    Call AddTranslation("DRIVE", "DR")
    Call AddTranslation("HIGHWAY", "HWY")
    Call AddTranslation("JUNCTION", "JCT")
    Call AddTranslation("LANE", "LN")
    Call AddTranslation("PARK", "PK")
    Call AddTranslation("PARKWAY", "PKWY")
    Call AddTranslation("PKY", "PKWY")
    Call AddTranslation("PLACE", "PL")
    Call AddTranslation("PLAZA", "PLZ")
    Call AddTranslation("POINT", "PT")
    Call AddTranslation("ROAD", "RD")
    Call AddTranslation("ROUTE", "RTE")
    Call AddTranslation("RT", "RTE")
    Call AddTranslation("STREET", "ST")
    Call AddTranslation("STR", "ST")
    Call AddTranslation("TERRACE", "TER")
    Call AddTranslation("TERR", "TER")
    Call AddTranslation("TRAIL", "TR")
    Call AddTranslation("TRL", "TR")
    Call AddTranslation("WAY", "WY")
    Call AddTranslation("SQ", "SQUARE")
    Call AddTranslation("BASEMENT", "BSMT")
    Call AddTranslation("BUILDING", "BLDG")
    Call AddTranslation("FLOOR", "FL")
    Call AddTranslation("SUITE", "STE")
    Call AddTranslation("NORTH", "N")
    Call AddTranslation("SOUTH", "S")
    Call AddTranslation("EAST", "E")
    Call AddTranslation("WEST", "W")
    Call AddTranslation("NORTHEAST", "NE")
    Call AddTranslation("SOUTHEAST", "SE")
    Call AddTranslation("NORTHWEST", "NW")
    Call AddTranslation("SOUTHWEST", "SW")
End Sub

*** end class ***

Usage:

Dim objAddr As Address
Set objAddr = New Address
objAddr.SplitAddress <address to split>
Debug.Print "Original: " & objAddr.Original
Debug.Print "House Number: " & objAddr.HouseNumber
Debug.Print "Predirectional: " & objAddr.Predirectional
Debug.Print "Street Name: " & objAddr.StreetName
Debug.Print "Street Type: " & objAddr.StreetType
Debug.Print "Postdirectional: " & objAddr.Postdirectional
Debug.Print "Extras: " & objAddr.Extras

0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now