復制並粘貼到下一個空行中的另一個工作表

Question

我是 VBA 的新手，很抱歉有任何愚蠢的問題......我有大量數據（大約 15k 行），我需要在其中找到特定的關鍵字，如果找到，請復制該行和接下來的 3 行。 這是我到目前為止所擁有的：

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

問題是，這只是復制一個結果，我需要擁有所有結果。 我知道我缺少循環宏，但是我被卡住了:(有人可以幫我完成這個任務嗎？提前致謝！

Answer 1

使用 Find 方法復制多個匹配項

Sub Kopiowanie()
    
    Const ROWS_COUNT As Long = 4
    Const SEARCH_STRING As String = "Teilschulderlass"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets("TEXT")
    Dim srg As Range
    Set srg = sws.Range("A1", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    Dim dws As Worksheet: Set dws = wb.Sheets("WYNIK")
    Dim dfCell As Range: Set dfCell = dws.Range("A1")
    Dim dcrg As Range: Set dcrg = dfCell.Resize(ROWS_COUNT)
    
    Dim sCell As Range: Set sCell = srg.Find(What:=SEARCH_STRING, _
        After:=srg.Cells(srg.Cells.Count), LookIn:=xlFormulas, LookAt:=xlPart)
    
    If sCell Is Nothing Then
        MsgBox "The string '" & SEARCH_STRING & "' was not found in '" _
            & srg.Address(0, 0) & "'.", vbExclamation
        Exit Sub
    End If
    
    Dim FirstAddress As String: FirstAddress = sCell.Address
    
    Dim scrg As Range
    
    Do
        Set scrg = sCell.Resize(ROWS_COUNT)
        dcrg.Value = scrg.Value
        Set dcrg = dcrg.Offset(ROWS_COUNT)
        Set sCell = srg.FindNext(After:=sCell)
    Loop Until sCell.Address = FirstAddress
    
    MsgBox "Jest!", vbInformation

End Sub