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-questions/797760-macro-find-text-replace-items-below-text-specific-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/ekbr242gcr7gdy6/Find%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/message-to-cross-posters-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