VBA批量复制含指定关键词行及后续3行至新工作表空行问题求助

我有大约15000行数据，需查找特定关键词「Teilschulderlass」，找到后将该行及后续3行复制到另一工作表的下一个空行。目前使用如下VBA代码仅能复制首个匹配结果，我知晓需添加循环但陷入困境，请求帮助完善代码：

Sub Kopiowanie()
Dim Cell As Range
Worksheets("TEXT").Activate
ActiveSheet.Columns("A:A").Select
Set Cell = Selection.Find(What:="Teilschulderlass", After:=ActiveCell, LookIn:=xlFormulas, _
  LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
  MatchCase:=False, SearchFormat:=False)

If Cell Is Nothing Then
    'do it something
    MsgBox ("Nie ma!")
Else
    'do it another thing
    MsgBox ("Jest!")
    Cell.Select
    ActiveCell.Resize(4, 1).Copy
    Sheets("WYNIK").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End If

End Sub

修改后的代码 #

Sub Kopiowanie()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim findRange As Range, firstFound As Range
    Dim targetRow As Long
    
    ' 直接定义源/目标工作表，避免Activate/Select提升效率
    Set wsSource = ThisWorkbook.Worksheets("TEXT")
    Set wsTarget = ThisWorkbook.Worksheets("WYNIK")
    
    ' 首次查找关键词
    Set findRange = wsSource.Columns("A:A").Find(What:="Teilschulderlass", _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    
    If findRange Is Nothing Then
        MsgBox "Nie ma!" ' 未找到匹配项
        Exit Sub
    End If
    
    Set firstFound = findRange ' 记录首个匹配位置，防止无限循环
    MsgBox "Jest!" ' 提示找到匹配项
    
    Do
        ' 获取目标表下一个空行
        targetRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
        ' 复制匹配行及后续3行的值到目标行
        wsSource.Range(findRange, findRange.Offset(3, 0)).Copy
        wsTarget.Cells(targetRow, "A").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        ' 查找下一个匹配项
        Set findRange = wsSource.Columns("A:A").FindNext(findRange)
        
    ' 循环终止条件：回到首个匹配位置时停止
    Loop Until findRange.Address = firstFound.Address
End Sub

关键优化说明 #

• 移除Activate/Select操作，直接通过工作表对象引用范围，提升代码稳定性与运行效率
• 用FindNext配合循环遍历所有匹配行
• 通过End(xlUp).Row + 1自动定位目标表的下一个空行，避免覆盖已有数据
• 记录首个匹配位置，防止循环无限执行

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