find rows and replace each with several rows

Option Explicit


Sub UpdateRecords()
   Dim ws           As Worksheet
   Dim LR           As Long
   Dim lLoop        As Long
   Dim rFoundCell   As Range




   Application.ScreenUpdating = False
   Set ws = Sheets("Sheet1")
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      With .Range(.Cells(7, 1), .Cells(LR, 1))
         Set rFoundCell = .Cells(1, 1)
         For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "date")




            Set rFoundCell = .Find(What:="date", After:=rFoundCell, _
                                   LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                   SearchDirection:=xlNext, MatchCase:=False)
            ws.Range("A1:H5").Copy
            .Cells(rFoundCell.Row - 6, "A").Insert Shift:=xlDown
         Next lLoop
      End With
      .AutoFilterMode = False
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      .Range("A1:A" & LR).AutoFilter Field:=1, Criteria1:="date"
      .Range("A6:A" & LR).SpecialCells(xlCellTypeVisible).EntireRow.Delete
      .AutoFilterMode = False




   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True




End Sub