excel - 找到最后一个匹配后，如何使循环停止

Question

我拥有的代码匹配某些标准，并基于将它们从导入页面复制到输出页面。从某种意义上说，它正在寻找所有正确的匹配项。但是，它找到的最后一个匹配是返回 3 次而不是 1 次。如何在找到最后一个匹配项后立即停止循环？
我必须注意，我对 VBA 的了解非常有限。此代码是在论坛成员的帮助下生成的。
如果需要，我也可以提交 excel 文件，如果这样可以让事情变得更容易。

Option Explicit

Dim wsImport As Worksheet

Sub Sample()
    Dim wsSpec As Worksheet
    
    Set wsImport = ThisWorkbook.Sheets("Import")
    Set wsSpec = ThisWorkbook.Sheets("Specifications")
    
    Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
    Dim aCell As Range, bCell As Range
    Dim origin As String, KeyToFind As String
    Dim rngDB As Range
    Dim strAdress As String
    
    With wsSpec
        CriteriaA = wsImport.Range("C3").Value2
        CriteriaB = wsImport.Range("C4").Value2
        CriteriaC = wsImport.Range("C5").Value2
        
        Set rngDB = .Range("h1", .Range("h" & Rows.Count).End(xlUp))
       
        Set aCell = rngDB.Find(What:=CriteriaA, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        If Not aCell Is Nothing Then
            strAdress = aCell.Address
            Do
                If aCell.Offset(, 1).Value2 = CriteriaB And _
                   aCell.Offset(, 2).Value2 = CriteriaC Then
                   origin = aCell.Offset(, 6).Value2
                   KeyToFind = aCell.Offset(, 7).Value2
                End If
                If origin = "Letters" Then
                    CopyRows "M", KeyToFind, True
                ElseIf origin = "Numbers" Then
                    CopyRows "H", KeyToFind, False
                End If
                 Set aCell = rngDB.FindNext(aCell)
            Loop While aCell.Address <> strAdress
        End If
    End With
End Sub
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
    Dim copyFrom As Range
    Dim lRow As Long
    Dim LastRow As Long
     
    With wsImport
        .AutoFilterMode = False
        
        lRow = .Range(Col & .Rows.Count).End(xlUp).Row

        With .Range(Col & "1:" & Col & lRow)
            If PartialString = False Then
                .AutoFilter Field:=1, Criteria1:=SearchString
            Else
                .AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
            End If
            
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells
        End With
        .AutoFilterMode = False
    End With
   
    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Sheets("Output")
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    If Not copyFrom Is Nothing Then
        If wsOutput.Range("A1") = "" Then
                copyFrom.Copy wsOutput.Range("A1")
        Else
                copyFrom.Copy wsOutput.Range("a" & LastRow)(2)
        End If
    End If
End Sub

编辑:
每个请求截图:
进口:

规范:

Answer 1

所以在您的数据中，第 1 行 london/university/old不符合条件 B 和 C 等 copyrow不会被调用，因为在这个阶段 origin是空的。您的最后 4 行，2 行匹配标准 A，但不匹配标准 B 和 C，因此将全部用 origin 复制= “字母”，因为那是最后一次 origin已设置(满足标准 B 和 C)，所以我认为这一定是您最终获得多份副本的原因。您需要您的 if "letters"/if "numbers" if criteria b and c met 中的代码代码 - 这就是为什么你得到最后一个 3 次

            If aCell.Offset(, 1).Value2 = CriteriaB And _
                aCell.Offset(, 2).Value2 = CriteriaC Then
                origin = aCell.Offset(, 6).Value2
                KeyToFind = aCell.Offset(, 7).Value2
                If origin = "Letters" Then
                    CopyRows "M", KeyToFind, True
                ElseIf origin = "Numbers" Then
                    CopyRows "H", KeyToFind, False
                End If
            End If