Excel VBA跨表按部门复制整行仅返回首个匹配项问题

程序只复制第一条匹配记录的核心原因有两个：

• 自定义查找函数使用的Range.Find方法默认仅返回搜索到的第一个匹配项，现有代码未编写遍历所有匹配结果的逻辑，同一姓名在数据源表中存在多条记录时，后续记录不会被识别。
• Range.Find会自动记忆上一次执行的查找参数（匹配模式、搜索起点、搜索方向等），代码未显式声明所有查找参数，容易出现匹配偏移、漏匹配问题。

另外现有粘贴逻辑仅在过程启动时计算一次目标表的粘贴起始行，若要复制同一人员的多条记录，也会出现行号不更新、内容覆盖的问题。

主过程 #

Sub copy2Sheets()
    Dim table As Worksheet: Set table = Worksheets("Table")
    Dim N As Long
    N = 117 '可修改为动态获取Table表最后一行：N = table.Cells(table.Rows.Count, "A").End(xlUp).Row，避免硬编码
    Dim i As Long
    Dim tempDep As String
    Dim tempName As String
    Dim targetSht As Worksheet
    
    '遍历Table表人员清单
    For i = 1 To N - 1
        tempDep = Trim(table.Cells(i, "B").Value)
        tempName = Trim(table.Cells(i, "A").Value)
        '跳过空值行
        If tempName <> "" And tempDep <> "" Then
            '判断目标部门表是否存在
            On Error Resume Next
            Set targetSht = Worksheets(tempDep)
            On Error GoTo 0
            If Not targetSht Is Nothing Then
                copyPaste tempName, targetSht
                Set targetSht = Nothing
            End If
        End If
    Next i
    MsgBox "数据复制完成"
End Sub

粘贴功能子过程 #

Sub copyPaste(Name As String, place As Worksheet)
    Dim wsSource As Worksheet
    Dim targSource As Worksheet: Set targSource = place
    Dim copyTo As Long
    Dim FoundCell As Range
    Dim firstFindAddr As String
    
    '绑定数据源工作表
    Set wsSource = Worksheets("Last Month's BBS SafeUnsafe by ")
    '获取目标表当前最后一行的下一行作为初始粘贴位置
    copyTo = targSource.Cells(targSource.Rows.Count, "A").End(xlUp).Row + 1
    
    '显式指定所有Find参数，查找第一个匹配项
    Set FoundCell = wsSource.Range("C:C").Find( _
        What:=Name, _
        After:=wsSource.Range("C" & wsSource.Rows.Count), _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False _
    )
    
    '未找到匹配项直接退出过程
    If FoundCell Is Nothing Then Exit Sub
    
    '记录第一个匹配项的地址，作为循环终止标记
    firstFindAddr = FoundCell.Address
    
    '循环遍历所有匹配项
    Do
        '复制整行到目标表
        wsSource.Rows(FoundCell.Row).Copy targSource.Range("A" & copyTo)
        '粘贴行号下移
        copyTo = copyTo + 1
        '查找下一个匹配项
        Set FoundCell = wsSource.Range("C:C").FindNext(After:=FoundCell)
    '直到回到第一个匹配项位置，终止循环
    Loop While Not FoundCell Is Nothing And FoundCell.Address <> firstFindAddr
End Sub

原自定义check函数已整合进粘贴子过程，不需要单独保留。

• 显式指定Find方法的全部核心参数，设置LookAt:=xlWhole做整单元格精确匹配，避免姓名部分重合导致的误匹配，同时屏蔽VBA默认记忆查找参数的问题。
• 增加全匹配项遍历逻辑：记录第一个匹配结果的单元格地址，通过FindNext循环查找所有同姓名的记录，直到回到首个匹配位置，确保同一人员的多条业务记录全部被抓取。
• 动态更新粘贴行号，每完成一次行复制就将粘贴位置下移一行，避免多记录粘贴时的内容覆盖问题。
• 增加基础容错逻辑：自动跳过空姓名/空部门的行，提前判断部门工作表是否存在，避免无效值、工作表不存在导致的运行中断。
• 移除主过程中第一行数据单独处理的冗余代码，统一纳入循环处理逻辑。

附表示例 #

• Sheet1（Table表）示例：
  
• Sheet2（数据源表）示例：
  

内容的提问来源于stack exchange，提问作者Jose Garcia