Excel VBA：如果将语句复制/粘贴到新工作表中，然后删除复制的行

Question

今天刚开始学习 VBA，试图让我在新工作中的生活更轻松。我实际上是在尝试查找列 E 具有字母“a”的每个实例，并将其粘贴到新创建的名为“Aton”的工作表中，然后删除带有“a”s 的原始行。

我尝试修改此处找到的解决方案：VBA: Copy and paste entire row based on if then statement / loop and push to 3 new sheets

当我将上述解决方案更改为“If wsSrc.Cells(i, "E").Value = "a" Then" 时，我遇到了问题。

    Sub Macro3()
        'Need "Dim"
        'Recommend "Long" rather than "Integer" for referring to rows and columns
        'i As Integer
        Dim i As Long
        'Declare "Number"
        Dim Number As Long
        'Declare a variable to refer to the sheet you are going to copy from
        Dim wsSrc As Worksheet
        Set wsSrc = ActiveSheet
        'Declare a variable to refer to the sheet you are going to copy to
        Dim wsDest As Worksheet
        'Declare three other worksheet variables for the three potential destinations
        Dim wsEqualA As Worksheet
        'Create the three sheets - do this once rather than in the loop
        Set wsEqualA = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        'Assign the worksheet names
        wsEqualA.Name = "Aton"

        'Determine last row in source sheet
        Number = wsSrc.Cells(wsSrc.Rows.Count, "C").End(xlUp).Row

        For i = 1 To Number


        'Determine which destination sheet to use
        If wsSrc.Cells(i, "E").Value = "a" Then
            Set wsDest = wsEqualA
        Else

        End If

        'Copy the current row from the source sheet to the next available row on the
        'destination sheet
        With wsDest

            wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With

        'Delete row if column E has an a
        If wsSrc.Cells(i, "E").Value = "a" Then
            Selection.EntireRow.Delete
        Else

        End If

    Next i
End Sub

Answer 1

坚持你的代码，你有三个问题

• 删除行时必须向后循环并避免跳过行

• 您正在复制和（尝试）删除 'If wsSrc.Cells(i, "E").Value = "a"' 块之外的行，因此不管当前行“i”列 E价值

• 您不想删除当前选定的范围行，但当前循环“i”行

把它们放在一起就是正确的相关sn-p；

Set wsDest = wsEqualA 'set target sheet once and for all outside the loop
For i = Number To 1 Step -1 'Loop backwards 
    If wsSrc.Cells(i, "E").Value = "a" Then
        'Copy the current row from the source sheet to the next available row on the destination sheet
        With wsDest
            wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)   'Copy wsSrc current “i” row and paste it to wsDest
            wsSrc.Rows(i).Delete   'Delete wsSrc current “i” row
        End With
    End If
Next

作为一种可能的增强功能，您可以交换“With...End With”块中的工作表引用，因为引用最“使用”的那个更有效：

        With wsSrc
            .Rows(i).Copy wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)   'Copy wsSrc current “i” row and paste it to wsDest
            .Rows(i).Delete   'Delete wsSrc current “i” row
        End With

Answer 2

您需要限定原始值所在的工作表。将Set ws = ThisWorkbook.Sheets("Sheet1") 行上的Sheet 更改为您的工作表名称。

---

1. 创建新工作表并设置对象
2. 创建要循环的范围，LoopRange（E2 向下到列中的最后一行）
3. 循环通过LoopRange。如果满足条件，则将单元格 MyCell 添加到单元格集合 (TargetRange)
4. 如果TargetRange 不为空（意味着您的条件至少满足一次），则将标题从ws 复制到ns
5. 将TargetRange从ws复制到ns
6. 从ws 中删除TargetRange

使用Union 收集单元格的好处是可以避免copy/paste/delete 的多次迭代。如果您的范围中有 50 个单元格符合您的条件，那么您将有 50 个 copy/paste/delete 实例，总共 150 个操作。

使用Union 方法，每个动作只有1 个实例，总共3 个动作，这将延长运行时间。

---

Option Explicit

Sub Learning()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ns As Worksheet: Set ns = Worksheets.Add(After:=(ThisWorkbook.Sheets.Count)) 'ns = new sheet
ns.Name = "Aton"

Dim LoopRange As Range, MyCell As Range, TargetRange As Range

Set LoopRange = ws.Range("E2:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row)

For Each MyCell In LoopRange 'Loop through column E
    If MyCell = "a" Then
        If TargetRange Is Nothing Then 'If no range has been set yet
            Set TargetRange = MyCell
        Else 'If a range has already been set
            Set TargetRange = Union(TargetRange, MyCell)
        End If
    End If
Next MyCell

Application.ScreenUpdating = False
    If Not TargetRange Is Nothing Then 'Make sure you don't try to copy a empty range
        ws.Range("A1").EntireRow.Copy ns.Range("A1") 'copy header from original sheet
        TargetRange.EntireRow.Copy ns.Range("A2")
        TargetRange.EntireRow.Delete
    Else
        MsgBox "No cells were found in Column E with value of 'a'"
    End If
Application.ScreenUpdating = True

End Sub

Answer 3

首先，不要使用ActiveSheet，它会导致多个问题。如果sheet1 不是您的源工作表，请更改它以满足您的需要。正如 urdearboy 建议的那样，我更喜欢使用过滤器，它不需要循环并且速度更快。我总是尽量保持代码简单，所以试试这个......

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Aton"

    With Sheet1.UsedRange
        .AutoFilter Field:=5, Criteria1:="a", Operator:=xlFilterValues
        .Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Aton").Range("A1")
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilter
    End With