excel - 如何快速判断一个字符串的一部分是否与另一个字符串匹配？

Question

我的地址列表有时在街道后缀末尾有垃圾，需要删除。例如Yada Yada St. apt#12需要变成Yada Yada St。现在，我从here找到了街道后缀及其变体的列表。 。我需要在 Excel 中完成这一切，因此我将 3 列后缀列表(第 1-3 列分别是主要街道后缀、常用街道后缀或缩写以及邮政服务标准后缀缩写)放入标记为 SuffixList 的工作表中，然后将将地址列表添加到工作表 1 中，这是代码所在的位置。

我创建了一个代码来检查每个地址的每个后缀变体(SuffixList 上的第 2 列)，并在我要检查的后缀之前和之后使用空格，以确保我没有捕获任何街道名称，而只是捕获街道后缀。我也有.并且，在代码中检查变化，如下所示。我现在使用的代码可以工作，只是需要很长时间，我正在寻找更快的方法。

此外，每当我找到匹配项时，我都会将所使用的街道后缀替换为官方正确的后缀(后缀列表中的第 3 列)。

当前代码:

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

更多示例:

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 用户 Potter 的回答:

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

你是对的；它很慢，因为每次比较内容时，您都会访问 Excel 应用程序，这比仅访问变量(例如变量)要慢得多。

我建议您将所需的相关字段复制到数组中，如下所示:

    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

从这里开始，您应该使用 suffixData(row, column) 来访问该工作表，就像它是实际工作表一样。经过一千多次迭代，您将看到明显的改进。

您可以对其他工作表执行相同的技巧并计算所有内容，甚至无需在执行昂贵的循环时查找 Excel。

相反也是可取的。您不想每次获得单元格的值时都写入该单元格。 最好将其写入二维数组，就像它是电子表格一样，然后将整个数组复制到工作表中。