Replace Text based on Matrix

[richmcgill]

I need to clean up the addresses in our database and I want to use the USPS address abbreviation matrix to help accomplish this.
There are two scenarios.
1. I need in a new cell using the USPS matrix (a sample of the options is below) replace the word matches. Street would become ST.
2. The second issue is I have a lot of addresses with apartment numbers or unit numbers but I need to pull those out. Apartment is always defined in the address as APT. Unit is always defined as Unit. I just need to pull these away from the address.

Make sense?
Any help is appreciated.

Scenario 1
Address
122 Man Street	122 Main St
568 Main Boulevard	568 Main BLVD
Scenario 2
235 Main St Apt 15	235 Main St	Apt 15
555 Main St Unit 25	555 Main St	Unit 25

USPS matrix

Street Suffix	Abbreviation
ALLEY​	ALY​
ANEX​	ANX​
ARCADE​	ARC​
AVENUE​	AVE​
BAYOU​	BYU​

 

[Artik]

Assuming:
1. you create two tables, Table1 for address data and Table2 for USPS. both tables are in the same sheet.
2. there are 3 empty columns to the right of Table1
you can use the below macro.
When importing data from the forum into the worksheet, an invisible ChrW(8203) character is appended to the end of the text in each cell. If you do not find these characters in your original data, you can replace the

oDic.Add Replace(CStr(USPSData(i, 1)), ChrW(8203), vbNullString), Replace(CStr(USPSData(i, 2)), ChrW(8203), vbNullString)

line with

oDic.Add CStr(USPSData(i, 1)),CStr(USPSData(i, 2))

Macro:

Sub AAA()
    Dim oDic As Object
    Dim USPSData As Variant
    Dim AddrssData As Variant
    Dim vStSuff As Variant
    Dim Result As Variant
    Dim v As Variant
    Dim wks As Worksheet
    Dim i As Long
    Dim j As Long
    Dim lM As Long

    Set oDic = CreateObject("Scripting.Dictionary")
    Set wks = ActiveSheet

    If wks.ListObjects("Table2").ListRows.Count = 0 Then
        MsgBox "USPS data not available", vbExclamation
        Exit Sub
    End If

    If wks.ListObjects("Table1").ListRows.Count = 0 Then
        MsgBox "No address data available", vbExclamation
        Exit Sub
    End If

    USPSData = wks.ListObjects("Table2").DataBodyRange.Value
    AddrssData = wks.ListObjects("Table1").DataBodyRange.Value
    ReDim Result(1 To UBound(AddrssData), 1 To 2)

    On Error Resume Next
    For i = 1 To UBound(USPSData)
        oDic.Add Replace(CStr(USPSData(i, 1)), ChrW(8203), vbNullString), Replace(CStr(USPSData(i, 2)), ChrW(8203), vbNullString)
    Next i

    vStSuff = oDic.Keys()
    lM = UBound(vStSuff)

    For i = 1 To UBound(AddrssData)
        Result(i, 1) = AddrssData(i, 1)
        For j = 0 To lM
            If InStr(1, Result(i, 1), " " & vStSuff(j), vbTextCompare) > 0 Then
                Result(i, 1) = Replace(Result(i, 1), " " & vStSuff(j), " " & oDic.Items()(j), Compare:=vbTextCompare)
                Exit For
            End If
        Next j

        If InStr(1, Result(i, 1), " Apt ", vbTextCompare) > 0 Then
            v = Empty
            v = Split(Result(i, 1), " Apt ")
            Result(i, 1) = v(0)
            If UBound(v) > 0 Then
                Result(i, 2) = "Apt " & v(1)
            End If
        End If

        If InStr(1, Result(i, 1), " Unit ", vbTextCompare) > 0 Then
            v = Empty
            v = Split(Result(i, 1), " Unit ")
            Result(i, 1) = v(0)
            If UBound(v) > 0 Then
                Result(i, 2) = "Unit " & v(1)
            End If
        End If
    Next i

    wks.ListObjects("Table1").DataBodyRange.Offset(, 2).Resize(UBound(Result), 2).Value = Result

End Sub

Artik

 

[richmcgill]

Sorry, I have been out of town. I will give this a try. Thank you so much for your help!’n