VBA Macro To Find Specific Text And Insert Text Few Rows Below

[Flupsie]

I have a workbook with several sheets and want to find "DEPR-GENERATORS" in Col B and insert "DEPR in front on the text from one row below to 5 rows below

This must exclude sheets "Data", "Accounts", "TB"

The macro is only affecting the active sheet

When running the macro the text is inserted for eg DEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPR-COMPUTER EQUIP

See Sample data

Sub find_Dep()
 Dim Sh As Worksheet
    Dim lr As Long
   For Each Sh In ActiveWorkbook.Worksheets
       Select Case Sh.Name
            Case "Data", "Accounts", "TB"
            Case Else

       
            
            With Sh
                lr = .Cells(.Rows.Count, "B").End(xlUp).Row
             Cells.Find(What:="DEPR-GENERATORS", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
                '.Range("B1:B" & lr).Resize(5).Replace What:="   ", Replacement:="DEPR", LookAt:=xlPart
        For i = 1 To 5
            ActiveCell.Offset(i, 1) = "DEPR" & Trim(ActiveCell.Offset(i))
        Next
End With

 End Select
Next Sh

End Sub

Your assistance in correcting the code is much appreciated