2

我的地址列表有时在需要删除的街道后缀末尾有垃圾。例如 Yada Yada St. apt#12 需要成为 Yada Yada St. 现在，我从这里找到了街道后缀及其变体的列表。我需要在 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

最终代码用户波特的回答：

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
4

1 回答 1

2

你是对的; 它很慢，因为每次比较内容时都会访问 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。

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

于 2013-04-02T15:26:55.377 回答