Question

我有四张包含原始数据的表格，我希望在我的工作簿中将其复制并单独留作交叉参考。然后我想用文本“proj def”删除单元格上方的所有行（它出现两次，但是在两个外观之间有单元格 - 这在我的代码中很明显）。我想在我的工作簿的前四页中执行此操作，同时单独保留原始的重复工作表，但只能使用标记为“ptd”的第一个工作表执行此操作。我试图激活下一个工作表“ytd”甚至删除原始工作表“ptd”，看看它是否允许我更改myRange的位置，但我没有成功。基本上我想在子方法中运行这个代码，第一个表单“ptd”运行两个，第二个表单“ytd”运行另外两个，“qtr”运行另外两个，“mth”运行最后2个。我非常感谢对我的示例代码所做的任何编辑。

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

删除包含多个工作表上的特定文本的所有行

1 个答案: