How to quickly determine if part of a string matches another string? - excel

Question

I have address lists that sometimes have junk at the end of the street suffix that needs to be removed. For example Yada Yada St. apt#12 needs to become Yada Yada St. Now, I have found a list of street suffixes and their variations from here. I need to do this all in excel so I put the 3 column list of suffixes (columns 1-3 being Primary Street Suffix, Commonly Used Street Suffix or Abbreviation, and Postal Service Standard Suffix Abbreviation respectively) into a worksheet labeled SuffixList and I put the address list into sheet 1 which is where the code is.
I created a code to check each address against each suffix variation (column 2 on SuffixList) using a space before and after the suffix I'm checking to make sure I'm not catching any street names, just the street suffixes. I also have the . and , variations being checked in the code as you can see below. The code I'm using now works, it just takes too long and I'm looking for a faster method.
Also, any time I find a match, I am replacing the street suffix used with the officially correct one (column 3 on suffix list).
Current Code:
Sub JunkRemover()
'Link to an official abbreviations list
'https://www.usps.com/send/official-abbreviations.htm
Dim Orig As String
Dim NewAddr As String
Dim x As Integer 'Row Reference
Dim i As Long 'Address List Iterator
Dim y As Integer 'SuffixList Iterator
Dim ChangeCount As Integer
'WARNING!!!!!!!!!!!!
'This code assumes address field is in column A and that the address column has no blanks.
'If that is not the case, replace 1 for the appropriate number for x
'a=1, b=2, c=3, d=4 etc.
x = 1
ChangeCount = 0
i = 2
While Cells(i, x) <> ""
Orig = UCase(Cells(i, x))
y = 2
While Sheets("SuffixList").Cells(y, 2) <> ""
If InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 2) & " ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 3) & " ")) + Len(Sheets("SuffixList").Cells(y, 3)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
ElseIf InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 2) & ". ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 3) & ". ")) + Len(Sheets("SuffixList").Cells(y, 3)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
ElseIf InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 2) & ", ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 3) & ", ")) + Len(Sheets("SuffixList").Cells(y, 3)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
End If
y = y + 1
Wend
i = i + 1
Wend
MsgBox ChangeCount & " Rows Changed", vbOKOnly
End Sub
Further Examples:
OrigAddress NewAddress
4000 NO MAIN ST 1 4000 NO MAIN ST
135 ALDEN ST APT3 135 ALDEN ST
1820 HIGHLAND AVE 1820 HIGHLAND AVE
4901 NO MAIN ST. REAR 4901 NO MAIN ST
1820 HIGHLAND AVE, 1 1820 HIGHLAND AVE
Final Code users Potter's answer:
Sub JunkRemover2()
'Link to an official abbreviations list
'https://www.usps.com/send/official-abbreviations.htm
Dim Orig As String
Dim NewAddr As String
Dim x As Integer 'Row Reference
Dim i As Long 'Address List Iterator
Dim y As Integer 'SuffixList Iterator
Dim ChangeCount As Integer
Dim PauseTime, Start, Finish, TotalTime As Double
Dim slRows As Double
Dim slCols As Integer
Dim slRowsAddr As Double
Dim slColsAddr As Integer
'WARNING!!!!!!!!!!!!
'This code assumes address field is in column A and that the address column has no blanks.
'If that is not the case, replace 1 for the appropriate number for x
'a=1, b=2, c=3, d=4 etc.
x = 1
ChangeCount = 0
With Sheets("SuffixList")
'i am using Column 1 to find out how many rows there are(change it if you want)
slRows = Sheets("SuffixList").Cells(Rows.Count, 1).End(xlUp).Row
slCols = Sheets("SuffixList").Cells(1, Columns.Count).End(xlToLeft).Column
suffixData = Sheets("SuffixList").Range(Sheets("SuffixList").Cells(2, 2), Sheets("SuffixList").Cells(slRows, slCols))
End With
i = 2
While Cells(i, x) <> ""
Orig = UCase(Cells(i, x))
For y = 1 To slRows - 1
If InStr(1, Orig, " " & UCase(suffixData(y, 1) & " ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(suffixData(y, 2) & " ")) + Len(suffixData(y, 2)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
Exit For
ElseIf InStr(1, Orig, " " & UCase(suffixData(y, 1) & ". ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(suffixData(y, 2) & ". ")) + Len(suffixData(y, 2)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
Exit For
ElseIf InStr(1, Orig, " " & UCase(suffixData(y, 1) & ", ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(suffixData(y, 2) & ", ")) + Len(suffixData(y, 2)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
Exit For
End If
Next
i = i + 1
Wend
MsgBox ChangeCount & " Rows Changed", vbOKOnly
End Sub

Answer 1

You're right; it is slow because every time you compare stuff you access the Excel application, which is considerably slower than just accessing, say, a variable.
I would suggest you copy the relevant fields you want to arrays like so:
dim suffixData as variant
'Now you need to save all that sheets' content into an array
'1stly you need the sheet's dimentions
dim slRows as double
dim slCols as integer
'I am using Column 1 to find out how many rows there are(change it if you want)
with Sheets("SuffixList")
slRows = .Cells(rows.count, 1).end(xlUp).row
slCols = .Cells(1, columns.count).end(xlToLeft).column
suffixData = .Range(.cells(1,1), .cells(slRows, slCols))
end with
From here onwards you should use suffixData(row, column) to access that sheet as if it was the actual sheet. On a thousand+ iterations on it you will see a definite improvements.
You can do the same trick with the other sheets and calculate everything without even looking up Excel while you do your costly loops.
The reverse is also advisable. You don't want to write to a cell each time you have its value.
It's much better to write it to a 2D array as if it was the spreadsheet and then copy the entire array to the sheet.