Copy and paste to another sheet in the next empty row - excel

Question

I'm a newbie in VBA, so sorry for any stupid questions...
I have a huge number of data (about 15k rows) in which I need to find specific key word and if found, copy the row and 3 next rows.
This is what I have till now:
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
The problem is, that is copying only one result and I need to have all of them.
I know that I'm lacking a loop macro, however I got stuck :(
Could someone help me with this task? Thanks in advance!

Answer 1

Copy Multiple Matches Using the Find Method
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