Macro to Find Text and replace items below text with specific text

[howard]

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

I have tried to write code -see below, but cannot get it to work. After running the code, the text below "DEPR-GENERATORS" must look like the text in Col C (C10:C14 -I have manually typed this in)

 Sub find_Depreciation()
 Dim Sh As Worksheet
    Dim lr As Long
   For Each Sh In ActiveWorkbook.Worksheets
       Select Case Sh.Name
            Case "Data", "Man Accounts Bank", "Profit Check"
            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
             
End With

 End Select
Next Sh

End Sub

https://www.dropbox.com/s/ekbr242gcr7gdy6/Find Depr.xlsm

It would be appreciated if you could assist me in resolving this

 

[L. Howard]

Hi howard,

This seems to work.

Regards,
Howard

Sub find_Depreciation()
 Dim Sh As Worksheet
    Dim lr As Long
   For Each Sh In ActiveWorkbook.Worksheets
       Select Case Sh.Name
            Case "ECM Consolidated", "Man Accounts Bank", "Profit Check"
            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

 

[howard]

Hi Howard

Many thanks for the help.

I amended to code to so that the changes take place in Col B. and it works perfectly on the workbook posted

I used this code in my actual workbook and it giving me for eg DEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPRDEPR-COMPUTER EQUIP

Please see incorrect results in Col C which I pasted from my actual workbook

Please amend your code so that the correct result as shown in B10:B14 is displayed


https://www.dropbox.com/s/ekbr242gcr7gdy6/Find Depr.xlsm

 

[L. Howard]

Hi howard,

I brought up one of my examples and was struggling with it and had to get some help.
I was trying to write with "With (MyArr(i))" instead of "With Sheets(MyArr(i))" and it wasn't working. Thanks to Claus for that.

This works on my test sheet, try it on your real sheet.

Howard

Option Explicit

Sub AFindIt()

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

MyArr = Array("Sheet1", "Sheet2", "Sheet3") '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 ii = 1 To 5
            c.Offset(ii) = "DEPR" & Trim(c.Offset(ii))
        Next ' ii
   End With

Next 'i
Application.ScreenUpdating = True
End Sub

 

[howard]

Hi Howard

Thanks for all your help, code works perfectly now

 

[L. Howard]

You're welcome.

Regards,
Howard

 

[howard]

Hi Howard

I have just picked up that if I update a second time I get for eg "DEPRDEPR-COMPUTER EQUIP'

I have tried amending code so that 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

It would be appreciated if you could amend

 Option Explicit
Sub AFindIt()




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

 

[L. Howard]

Hi howard,

Maybe this?

Howard

Option Explicit

Sub AFindItRepeatUpDate()

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

MyArr = Array("Sheet1", "Sheet2", "Sheet3") '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)
                
           [B]If (Left(c.Offset(1), 4)) = "DEPR" Then GoTo upDate[/B]  
                 
        ' Put DEPR in front of the text in the next 5 rows below found Text "DEPR-GENERATORS"
        For ii = 1 To 5
            c.Offset(ii) = "DEPR" & Trim(c.Offset(ii))
        Next ' ii
   End With

Next 'I

[B]upDate:[/B]

Application.ScreenUpdating = True
End Sub

 

[howard]

Hi Howard

Thanks very much-problem resolved

 

[L. Howard]

Okay, Great!

Regards,
Howard