Question

我有地址列表，有时在街道后缀的末尾有垃圾需要删除。例如Yada Yada St. apt＃12需要成为Yada Yada St.现在，我找到了here的街道后缀及其变体列表。我需要在Excel中执行此操作，因此我将3列后缀列表（第1-3列分别为Primary Street Suffix，常用街道后缀或缩写，以及邮政服务标准后缀缩写）分别标记为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。

反之亦然。每次有值时，您都不希望写入单元格。将它写入2D数组更好，就好像它是电子表格一样，然后将整个数组复制到工作表中。

如何快速确定字符串的一部分是否与另一个字符串匹配？

1 个答案: