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

[snb]

Sample Data ????

[Ingolf]

Cross post

http://www.mrexcel.com/forum/excel-q...ific-text.html

[Flupsie]

Have managed to sort out the code, but want to exit code after finding "DEPR" one row below DEPR-GENERATORS, the macro must stop, otherwise Insert "DEPR" in front of the text five rows below, but cannot get it to work

 Option Explicit
Sub Find_Depr ()




Dim i As Long, ii As Long, iii As Long
Dim MyArr As Variant
Dim c As Range

MyArr = Array("Br1", "Br2", "Br3") 'Your sheet names
              
Application.ScreenUpdating = False

For i = LBound(MyArr) To UBound(MyArr)

   With Sheets(MyArr(i))

        ' "DEPR-GENERATORS" will be in Column B1:Bn
        Set c = .Range("B:B").Find(What:="DEPR-GENERATORS", _
                After:=.Range("B1"), _
                LookAt:=xlWhole, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext)
                      
        ' Put DEPR in front of the text in the next 5 rows below found Text "DEPR-GENERATORS"
       For iii = 1 To 1
       
        If c.Offset(iii) Like "Depr" Then
        Exit Sub
        
       End If
        Else
         For ii = 1 To 5
            c.Offset(ii) = "DEPR" & Trim(c.Offset(ii))
        Next ' ii
   End With

Next 'i
Application.ScreenUpdating = True
End Sub

see sample data below
https://www.dropbox.com/s/ekbr242gcr...nd%20Depr.xlsm

[snb]

I don't like crossposts, nor files on external servers (if they have been deleted there this whole thread wil fall into smithereens....)

[bakerman]

Flupsie,
Please read following link regarding you crossposting.
http://www.excelfox.com/forum/f25/me...1172/#post5326

Also, on the other forum you have marked your question as resolved.
Out of respect for all the helpers here who share their expertise free of charge you could have put a message here informing everyone that you have received a suitable answer to your question.

[Flupsie]

My apologies for not showing the link to the crosspost

Problem now resolved