Find and Replace Code to Multiple Subs

[pwill]

Hi can anyone help with replacing the lines in RED with the lines in Blue to multiple subs?
​

Sub dups1()

[COLOR=#ff0000]    Sheets("Sheet11").Select
    
    Dim Sheet11 As Worksheet: Set Sheet11 = Sheet11
    Dim lRow As Long
    
    lRow = Sheet11.Cells(Rows.Count, "A").End(xlUp).Row[/COLOR]
    Range("A1:BD" & lRow).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter
    ActiveSheet.Range("A1:BD" & lRow).AutoFilter Field:=3, Criteria1:="6"
    Selection.Copy
    Sheets("Sheet12").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Sheets("Sheet11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Range("A1").Select
    
    Sheets("Sheet2").Select
End Sub

Sub dups2()

[COLOR=#0000ff]    Dim Sheet2 As Worksheet: Set Sheet2 = Sheet02
    Dim Sheet11 As Worksheet: Set Sheet11 = Sheet11
    Dim lRow As Long
  
        Application.ScreenUpdating = False
    
        lRow = Sheet11.Cells(Rows.Count, "A").End(xlUp).Row
        
    Sheet11.Activate[/COLOR]
    Range("A1:BD" & lRow).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter
    ActiveSheet.Range("A1:BD" & lRow).AutoFilter Field:=51, Criteria1:="-5"
    Selection.Copy
    Sheets("Sheet12").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Sheets("Sheet11").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Range("A1").Select
    
    Sheets("Sheet2").Select
    
End Sub

Any help would be appreciated

Regards

pwill

 

[mole999]

I would export the sub(s) then open in word, create the find replace, and then reimport, just need to tidy the lines together first so that it works first time

 

[pwill]

Thanks mole999, I will give that a try

pwill

 

[pwill]

I would export the sub(s) then open in word, create the find replace, and then reimport, just need to tidy the lines together first so that it works first time

Hi mole999, I have had a go on word but I really don't know where to start,

could you help with how to create the find and replace and any other tips you may have?

Regards

pwill

 

[mole999]

Just tried it myself and its limited by the Paragraph mark so it won't find replace the whole text I wash hoping word would just except the whole text as tested. I don't have any better idea at the moment

 

[pwill]

No worries, thank you for trying mole999, much appreciated

pwill

 

[mole999]

Just found this > https://answers.microsoft.com/en-us...t/f7b1d553-6262-43e8-b340-055f965789aa?auth=1

 

[pwill]

Thanks mole999 I will have a look at that much appreciated,

I did have an idea of my own that I gave a try this morning and all was going well until the end bit.

I have 210 subs all with the same code except for the Name and a different range for filtering, Sub names run from

Sub A1 to A30 then

B1 to 30,
C1 to 30,
D1 to 30,
E1 to 30,
F1 to 30,
G1 to 30

So what I did was keep the first sub how I want it then Counted the number of lines in the first Sub starting with the Sub name

ie

[/FONT][/COLOR][COLOR=#222222][FONT=Verdana]Sub A1()[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]    Dim Sht2 As Worksheet: Set2 Sht = Sheet02
    Dim Sht11 As Worksheet: Set Sht11 = Sheet11
    Dim Filtr As Worksheet: Set Filtr = Sheet14
    Dim C As Long
  
        Application.ScreenUpdating = False
  
            Sheets("Filtr").Range("A1:BD1" & Sheets("Filtr").Cells(Rows.Count, 2).End(3).Row) = ""
  
    CellCountB.Activate
          For C = 2 To 2
    
            Range("B1:BD1" & Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter C - 1, 1
            Range("A1:BD" & Cells(Rows.Count, 2).End(xlUp).Row).Copy _
            Sheets("Filtr").Cells(Rows.Count, 1).End(3)(1)
                ActiveSheet.AutoFilterMode = False
   
          Next C
  
        Sht2.Activate
   
    Application.ScreenUpdating = True
   
End Sub[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana] [/FONT][/COLOR][COLOR=#222222][FONT=Verdana]

Then under the first Sub repeated a list of numbers x(209) with spaces as within the first sub and replaced the numbers with each line from the first Sub Starting with 'Sub A1'
the only problem is I was left with all the Subs having the same name which meant still having to scroll through them all to change the name and the ranges

ie

1
2
3
4

5

6

7
8

9
10
11
12

13

14

15

16
<strike></strike>
​