vba - 将一张纸中的每个名称与另一张纸中的每个字符串进行比较

Question

有两张名为“Agents”的工作表，另一张名为“Owners”，现在 Agents 工作表在“C”列中约有 37k 行，名称如“CLARKE、DENISE JANE”全部位于一个单元格中。

另一张表“Owners”在“A”列中的姓名大约有 1k 行，格式如下“Rafael”、“William”、“Smith”等，全部位于不同的行中。

我正在尝试将所有者表中的每个名称与代理表中的每个字符串进行比较。

在这种情况下。首先，如果发现 Rafael 的背景颜色匹配，则 Rafael 将与 CLARKE 进行比较，然后与 DENISE 进行比较，然后与 JANE 进行比较

现在，当我运行这段代码时，它可能会进入无限循环或其他什么情况，但 Excel 很长时间没有响应，比如 5 - 8 分钟就会卡住。即使“Ctrl + Break”也不起作用，我必须通过任务管理器终止它。我尝试找出此代码中的任何缺陷，但未能成功。

有人可以帮忙吗？

Option Explicit
Sub Duplica()
    Dim str1 As String
    Dim str2 As String
    Dim i, j, m, d, k, l As Long
    Dim FinalRow, FinalRow1 As Long
    Dim ws, wr As Worksheet
    Dim pos As Integer
    Dim Own
    Dim Ago

    Application.ScreenUpdating = False
    Set ws = Sheets("Agents")
    Set wr = Sheets("Owners")

    FinalRow = ws.Range("C90000").End(xlUp).Row
    FinalRow1 = wr.Range("A90000").End(xlUp).Row

    For i = 1 To FinalRow
        l = 0
        pos = 0

        With ws
        str1 = .Cells(i, "C").Text
        str1 = Replace(str1, "&", " ")
        str1 = Replace(str1, ",", " ")
        Ago = Split(str1, " ")
        End With

        For d = 1 To FinalRow1
            With wr
            str2 = .Cells(d, "A").Text
            str2 = Replace(str2, "&", " ")
            str2 = Replace(str2, ",", " ")
            Own = Split(str2, " ")
            End With

            For m = LBound(Ago) To UBound(Ago)
                For j = LBound(Own) To UBound(Own)
                    If Len(Own(j)) > 0 And Len(Ago(m)) > 0 Then     'if not a empty string
                    pos = InStr(1, Ago(m), Own(j), vbTextCompare)    'Find the owners name in Agents name
                    If Own(j) = Ago(m) Then                           'If both are same
                    l = l + 1                                          'increment l
                    Else: End If
                    Else: End If

                    If l > 0 Or pos >= 1 Then
                    With wr
                    .Cells(d, "A").Interior.ColorIndex = 3
                    End With
                    l = 0
                    pos = 0
                    Else: End If
                    l = 0
                    pos = 0

                Next j
            Next m
        Next d
    Next i
End Sub

Answer 1

试试这个。它更直接一些。由于需要处理大量数据，因此仍需要几分钟的时间。

LookAt:=xlPart 的查找选项使我们能够搜索字段的任何部分。让我知道这个是否奏效。唯一的问题是我们可能有一个名为 bob 的所有者和一个名为 Jimbob 的代理人。那会很受欢迎。如果存在问题，我们可以将其更改为查看每个名称。

Sub Duplica()

    Dim wsAgents As Excel.Worksheet
    Dim wsOwners As Excel.Worksheet
    Dim lRow As Long
    Dim Rng As Range
    Dim lastRow As Long

    Set wsAgents = ActiveWorkbook.Sheets("Agents")
    Set wsOwners = ActiveWorkbook.Sheets("Owners")

    'Get the last row that has an owner name
    lastRow = wsOwners.Cells(wsOwners.Rows.count, "A").End(xlUp).Row

    'Loop through the sheet with the owners
    lRow = 1
    Do While lRow <= lastRow

        'Search for the owners name in the column on the agents sheet.
        Set Rng = wsAgents.Range("C:C").Find(What:=UCase(wsOwners.Range("A" & lRow).Value), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

        'If we found the owner on the agent sheet color the owners name red.
        If Not Rng Is Nothing Then
            wsOwners.Range("A" & lRow).Interior.ColorIndex = 3
        End If
    Debug.Print str(lRow)

    'Increment to the next row
    lRow = lRow + 1
    Loop

End Sub