Sub StartEnd()
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FoundTrigger As Range
Dim FAdr As String
Dim FRow As Long
Dim ERow As Long
Dim List2 As Worksheet
   Set List2 = ThisWorkbook.Worksheets("Лист2")
     List2.Cells.Clear
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With Range("A1:A" & iLastRow)
    Set FoundCell = .Find("Начало", .Cells(.Cells.Count), xlValues, xlWhole, , xlNext)
    If Not FoundCell Is Nothing Then
     FAdr = FoundCell.Address
     FRow = FoundCell.Row
      Do
       Set FoundCell = .FindNext(FoundCell)
       ERow = FoundCell.Row - 2
       If ERow > FRow And ERow < iLastRow Then
       Else
         ERow = iLastRow
       End If
         Set FoundTrigger = Range(Cells(FRow, "A"), Cells(ERow, "D")).Find("Триггер", , xlValues, xlWhole)
           If Not FoundTrigger Is Nothing Then
             iLR = List2.Cells(List2.Rows.Count, 1).End(xlUp).Row + 2
             Range(Cells(FRow, "A"), Cells(ERow, "D")).Copy List2.Cells(iLR, 1)
           End If
       Set FoundCell = .Find("Начало", .Cells(FRow, "A"), xlValues, xlWhole)
       FRow = FoundCell.Row
      Loop While FoundCell.Address <> FAdr
    End If
 End With
   List2.Rows("1:2").Delete
End Sub