how to LOOP/Repeat a Find macro

[misula29]

I am trying to search an entire sheet for a certain word "consolidated", and when the word appears i want the following macro to run ... but then i want this to repeat throughout the entire sheet ... please help! currently it just finds 'Consolidated" once and the macro ends

Sub PreStep1()
Cells.Find(What:="consolidated", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Insert
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Select
Selection.Copy
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
ActiveCell.Select
ActiveCell.Offset(0, 3).Select
ActiveCell.FormulaR1C1 = "FEE"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=R[1]C+R[2]C"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=R[1]C+R[2]C"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=R[1]C+R[2]C"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=R[1]C+R[2]C"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=R[1]C+R[2]C"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=R[1]C+R[2]C"
ActiveCell.EntireRow.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Select
Selection.Delete
Selection.Delete

End Sub

 

[WhatTheXL]

Make Sure to test this on a COPY of your Data.

Sub PreStep1()
   Dim lngLastCol As Long
   Dim lngLastRow As Long
   Dim lngCol As Long
   Dim lngRow As Long
   Dim rngFound As Range
   Dim rngLastCell As Range
   Dim strFirstFound As String
 
   lngLastCol = Cells.Find(what:="*", after:=Cells(1, 1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
   lngLastRow = Cells.Find(what:="*", after:=Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
   Set rngLastCell = Cells(lngLastRow, lngLastCol)
   Set rngFound = Cells.Find(what:="consolidated", after:=rngLastCell)
 
   If Not rngFound Is Nothing Then strFirstFound = rngFound.Address
 
   Do Until rngFound Is Nothing
      lngRow = rngFound.Row
      Cells(lngRow, 4) = "FEE"
      For lngCol = 5 To 10
         Cells(lngRow, lngCol) = Cells(lngRow, lngCol) + Cells(lngRow + 1, lngCol)
      Next lngCol
      Cells(lngRow + 1, 1).EntireRow.Delete
 
      Set rngFound = Cells.FindNext(after:=rngFound)
      If rngFound.Address = strFirstFound Then Exit Do
   Loop
 
CleanExit:
   Set rngFound = Nothing
   Set rngLastCell = Nothing
End Sub