我仔细看了你的代码和需求，问题核心在于目标粘贴位置没有随匹配行递增，再加上工作表名称引用错误，导致每次复制都覆盖了之前的结果，最终只留下最后一行匹配数据。下面是针对你的需求修正后的解决方案：

修正后的VBA代码（基于你的原逻辑优化） #

Sub CopyMatchingRows()
    Dim wsRaw As Worksheet
    Dim wsReport As Worksheet
    Dim rngFound As Range
    Dim strFirstMatch As String
    Dim strTargetID As String
    Dim nextPasteRow As Long ' 记录Report中下一次粘贴的行号
    
    ' 绑定实际工作表，替换成你需求里的表名
    Set wsRaw = ThisWorkbook.Worksheets("RawData")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    
    ' 获取Report表A1的目标匹配值
    strTargetID = wsReport.Range("A1").Value
    If strTargetID = "" Then
        MsgBox "A1单元格不能为空，请输入需要匹配的编号！", vbExclamation
        Exit Sub
    End If
    
    ' 初始化粘贴起始行：从Report的B4开始
    nextPasteRow = 4
    
    ' 在RawData的B列查找目标值，不区分大小写
    Set rngFound = wsRaw.Columns("B").Find( _
        What:=strTargetID, _
        After:=wsRaw.Cells(wsRaw.Rows.Count, "B"), _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        MatchCase:=False)
    
    If Not rngFound Is Nothing Then
        strFirstMatch = rngFound.Address ' 记录第一个匹配项地址，防止死循环
        Do
            ' 复制当前匹配行的A-D列到Report的B列对应行
            wsRaw.Range("A" & rngFound.Row & ":D" & rngFound.Row).Copy _
                Destination:=wsReport.Range("B" & nextPasteRow)
            
            ' 递增行号，确保下一行粘贴到新位置
            nextPasteRow = nextPasteRow + 1
            
            ' 查找下一个匹配项
            Set rngFound = wsRaw.Columns("B").FindNext(rngFound)
        Loop While rngFound.Address <> strFirstMatch ' 回到第一个匹配项时结束循环
    Else
        MsgBox "未找到匹配" & strTargetID & "的数据！", vbInformation
    End If
    
    ' 释放对象占用的内存
    Set rngFound = Nothing
    Set wsRaw = Nothing
    Set wsReport = Nothing
End Sub

关键修改点说明 #

• 工作表引用修正：把原代码里的test/test1替换成你实际的RawData/Report，避免引用错误。
• 目标行号递增：新增nextPasteRow变量，每次复制后自动加1，彻底解决覆盖问题。
• 简化大小写判断：用MatchCase:=False替代原代码的LCase转换，逻辑更简洁高效。
• 增加空值校验：避免A1为空时执行无效查找，提升代码健壮性。
• 规范查找逻辑：改用FindNext替代重复调用Find，代码更简洁易维护。

大数据量高效替代方案（AutoFilter） #

如果你的数据行数较多，用Excel内置的筛选功能会比循环查找快很多，代码如下：

Sub CopyWithAutoFilter()
    Dim wsRaw As Worksheet
    Dim wsReport As Worksheet
    Dim rngFullData As Range
    Dim strTargetID As String
    
    Set wsRaw = ThisWorkbook.Worksheets("RawData")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    strTargetID = wsReport.Range("A1").Value
    
    If strTargetID = "" Then
        MsgBox "A1单元格不能为空，请输入需要匹配的编号！", vbExclamation
        Exit Sub
    End If
    
    ' 清除RawData之前的筛选状态
    wsRaw.AutoFilterMode = False
    
    ' 定义完整数据范围（假设第一行是表头）
    Set rngFullData = wsRaw.Range("A1:D" & wsRaw.Cells(wsRaw.Rows.Count, "A").End(xlUp).Row)
    
    ' 对B列应用筛选，匹配目标值
    rngFullData.AutoFilter Field:=2, Criteria1:=strTargetID
    
    ' 复制筛选后的可见行（跳过表头）到Report的B4
    On Error Resume Next ' 处理无匹配数据的情况
    rngFullData.Offset(1).SpecialCells(xlCellTypeVisible).Copy _
        Destination:=wsReport.Range("B4")
    On Error GoTo 0
    
    ' 清除筛选
    wsRaw.AutoFilterMode = False
    
    Set rngFullData = Nothing
    Set wsRaw = Nothing
    Set wsReport = Nothing
End Sub

这个方案利用Excel原生筛选，一次性复制所有匹配行，性能远优于循环查找，适合处理上千行的大数据量。

内容的提问来源于stack exchange，提问作者Andriano Crs