如何修改VBA代码遍历姓名所有出现实例并复制对应行？

原代码仅能复制姓名首次出现的行，要实现复制所有匹配实例，核心是用FindNext方法循环遍历所有匹配项，具体修改如下：

原代码问题分析 #

原代码仅调用一次Find方法，只会返回第一个匹配的单元格，因此只能复制第一行匹配数据。要捕获所有匹配项，需要结合FindNext和循环结构，遍历所有符合条件的单元格。

修改后的完整代码 #

Sub copy2Sheets()
    Const N As Long = 116 '固定值使用常量
    
    Dim wsTable As Worksheet, wsBBS As Worksheet, i As Long
    Dim wsDest As Worksheet, f As Range, tempDep As String, tempName As String
    Dim firstAddr As String '保存首次匹配的单元格地址，避免无限循环
    
    Set wsTable = ThisWorkbook.Worksheets("Table")
    Set wsBBS = ThisWorkbook.Worksheets("Last Month's BBS SafeUnsafe by ")
    
    For i = 1 To N
        tempDep = Trim(wsTable.Cells(i, "B").Value)
        tempName = Trim(wsTable.Cells(i, "A").Value)
        If Len(tempName) > 0 Then
            Set wsDest = ThisWorkbook.Worksheets(tempDep)
            '首次查找目标姓名
            Set f = wsBBS.Columns("C").Find(what:=tempName, lookat:=xlWhole)
            If Not f Is Nothing Then
                firstAddr = f.Address '记录第一个匹配项的地址
                Do
                    '复制当前匹配行到目标工作表
                    f.EntireRow.Copy wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
                    '查找下一个匹配项
                    Set f = wsBBS.Columns("C").FindNext(f)
                '循环直到回到第一个匹配项地址，结束遍历
                Loop While Not f Is Nothing And f.Address <> firstAddr
            End If
        End If
    Next i
End Sub

关键修改说明 #

• 新增变量firstAddr：用于存储第一个匹配单元格的地址，作为循环终止条件，防止无限循环。
• 替换单条If判断为Do...Loop循环：
  1. 首次找到匹配项后，先记录其地址
  2. 复制当前匹配行到目标工作表
  3. 调用FindNext查找下一个匹配项
  4. 当找不到匹配项，或者回到第一个匹配项地址时，终止循环

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