Question

我有一些代码，所以我可以将特定的行移动到特定的表格，其结构如下：

表1（包含所有数据）
表2（要移动的目标表）

所以基本上代码在特定列上查找关键字，并将指定列上符合该条件的所有行从工作表1复制到工作表2，它就像魅力一样。我遇到的问题是因为数据组织，我需要在复制后删除行，我尝试使用.cut target代替.copy target，它也可以，但需要很长时间（大约1分钟以上，看起来整个时间都冻结了，因为它不会让你选择任何东西。

有任何建议可以更有效地完成此任务吗？我正在学习VBA，所以请耐心等待。

Sub Copydatatoothersheet()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    j = 3     ' Start copying to row 3 in target sheet
    Application.ScreenUpdating = False
    For Each c In Source.Range("BB:BB")
        If c = "UNPAID" Then
        'THIS IS THE LINE WHERE I REPLACE COPY WITH CUT
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
    Application.ScreenUpdating = True
End Sub

Answer 1

尝试在变量中存储所需的范围，然后删除该存储范围的整行

Sub Copydatatoothersheet()
Dim c As Range
Dim j As Integer
Dim source As Worksheet
Dim target As Worksheet
Dim oRange As Range

' Change worksheet designations as needed
Set source = ActiveWorkbook.Worksheets("Sheet1")
Set target = ActiveWorkbook.Worksheets("Sheet2")

j = 3     ' Start copying to row 3 in target sheet
Application.ScreenUpdating = False
For Each c In source.Range("BB:BB")
    If c = "UNPAID" Then
    'THIS IS THE LINE WHERE I REPLACE COPY WITH CUT
       source.Rows(c.Row).Copy target.Rows(j)
       If oRange Is Nothing Then Set oRange = c Else Set oRange = 
Union(oRange, c)
       j = j + 1
    End If
Next c
If Not oRange Is Nothing Then oRange.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Answer 2

使用AutoFilter

Sub foo()
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    With Source
        With .Range("BB:BB" & .Cells(.Rows.Count, "BB").End(xlUp).Row) 'reference its column BB cells from row 1 (header) down to last not empty one
            .AutoFilter field:=1, Criteria1:= "UNPAID"' filter referenced cells on 1st column with "UNPAID" content
            If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
                With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                    Intersect(.EntireRow, .Parent.UsedRange), .Parent.UsedRange).Copy Destination:=Target.Range("A1") ' if any filtered cell other than the header then copy their entire rows and paste to 'Target' sheet starting from its cell A1
                    .EntireRow.Delete ‘finally, delete these rows
                End With
            End If
        End With
        .AutoFilterMode = False
    End With
End Sub

您也可以添加ScreenUpdating切换

根据条件删除行

2 个答案: