刪除在多張紙上包含特定文本的所有行

Question

我有四張帶原始數據的工作表，我希望在工作簿中將其複製並單獨留作交叉參考。然後，我想用文本「proj def」刪除單元格上方的所有行（它會出現兩次，但兩個外觀之間存在單元格 - 這在我的代碼中很明顯）。我希望爲我的工作簿的前四張工作簿執行此操作，而僅保留原始的重複工作表，但只能在第一個標記爲「ptd」的工作表中執行此操作。我嘗試激活下一張工作表「ytd」，甚至刪除原始工作表「ptd」，看看它是否允許我更改myRange的位置，但我沒有成功。基本上我想在子方法中運行這個代碼，其中兩個用於第一個工作表「ptd」，另外兩個用於第二個工作表「ytd」，另外兩個用於「qtr」，最後2個用於「mth」。任何編輯我的示例代碼將不勝感激。

Sub part1() 
    Worksheets("ptd").Copy After:=Worksheets("mth") 
    Worksheets("ytd").Copy After:=Worksheets("ptd (2)") 
    Worksheets("qtr").Copy After:=Worksheets("ytd (2)") 
    Worksheets("mth").Copy After:=Worksheets("qtr (2)") 
End Sub 
Sub part2() 
Worksheets("ptd").Activate 
Set rngActiveRange = ActiveCell 
      Dim MyRange As Range 
      Set MyRange = ActiveSheet.Range("A:A") 
      MyRange.Find("Customer Unit", LookIn:=xlValues).Select 
      rngActiveRange.Offset(-1, 0).Select 
      Range(rngActiveRange.Row & ":" & 1).Rows.Delete 
End Sub 
Sub part3() 
    Dim MyRange As Range 
    Set MyRange = ActiveSheet.Range("A:A") 
    MyRange.Find("Project Definition", LookIn:=xlValues).Select 
    ActiveCell.Offset(-1, 0).Select 
    Range(ActiveCell.Row & ":" & 1).Rows.Delete 
End Sub 
Sub part4() 
Worksheets("ytd").Activate 
Set rngActiveRange = ActiveCell 
      Dim MyRange As Range 
      Set MyRange = ActiveSheet.Range("A:A") 
      MyRange.Find("Customer Unit", LookIn:=xlValues).Select 
      rngActiveRange.Offset(-1, 0).Select 
      Range(rngActiveRange.Row & ":" & 1).Rows.Delete 
End Sub 
Sub part5() 
    Dim MyRange As Range 
    Set MyRange = ActiveSheet.Range("A:A") 
    MyRange.Find("Project Definition", LookIn:=xlValues).Select 
    ActiveCell.Offset(-1, 0).Select 
    Range(ActiveCell.Row & ":" & 1).Rows.Delete 
End Sub 

Answer 1

如果我理解正確，下面應該可以工作。我做的主要事情是用avoiding the use of .Select/.Activate重寫。

Sub remove_Rows() 
Dim ws  As Worksheet 
Dim foundCel As Range 

' Copy sheets 
Worksheets("ptd").Copy After:=Worksheets("mth") 
Worksheets("ytd").Copy After:=Worksheets("ptd (2)") 
Worksheets("qtr").Copy After:=Worksheets("ytd (2)") 
Worksheets("mth").Copy After:=Worksheets("qtr (2)") 

' Start removing rows 
For Each ws In ActiveWorkbook.Worksheets 
    With ws 
     If InStr(1, .Name, "(") = 0 Then 
      Set foundCel = .Range("A:A").Find("Customer Unit", LookIn:=xlValues) 
      .Range(foundCel.Offset(-1, 0).Row & ":" & 1).Rows.Delete 
      Set foundCel = .Range("A:A").Find("Project Definition", LookIn:=xlValues) 
      .Range(foundCel.Offset(-1, 0).Row & ":" & 1).Rows.Delete 
     End If 
    End With 
Next ws 

End Sub