Excel VBA复制未出现在两个数组中且没有特定值的行

Question

我只想复制那些行，它们在第 1 列中的值没有出现在两个单独的数组中，并且在第 3 列中的值 = 0。

例如，我的数据如下所示：

Name ID flag

Alice 1232 0

Alice 885  0

Alice 8332 1

Bob  993  1

Dan 9932  0

Chet 12  1

Fiona  993 0

Array1 = (鲍勃，菲奥娜)

Array2 = (丹)

所以我不想复制 Dan、Fiona 和 Bob。剩下的，只有 ALice 的前两个条目在第三列有 0，所以我想复制并粘贴到新工作表中

Name ID flag

Alice 1232 0

Alice 885  0

我想做一个自动过滤器，但我的数组中有 2000 到 4000 个元素，我不能使用 Array11 = (Bob, Fiona) 等等。

我有一个包含所有名称的数组，比如 ArrayAll = (Alice, Bob, Chet, Dan, Fiona) 但我不知道如何进行集合理论运算，从 ArrayAll 中减去 Array1 和 Array2，没有做两个很长的循环会超级慢。

现在，我不是过滤和复制，而是复制所有内容，然后根据两个数组和第三个条件自动过滤和删除。问题是我的代码超级超级超级慢。

  Set wb1 = ActiveWorkbook
Set ws1 = wb1.Worksheets("SCL_FL")
'    strSearch = "SCL_FL"
           With ws1
               .AutoFilterMode = False
               lRow = .Range("A" & .Rows.Count).End(xlUp).Row
                With .UsedRange
            'Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
                    Set copyFrom = .EntireRow
               End With
              .AutoFilterMode = False
           End With
            Set ws3 = ActiveWorkbook.Worksheets.Add
            With ws3
               If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                  lRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
              Else
                  lRow = 1
              End If
              copyFrom.Copy .Range("A1")
             .Name = "Rest"
             .AutoFilterMode = False
             .UsedRange.AutoFilter Field:=2, Criteria1:=Array2()
             .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
             .AutoFilterMode = False
             .AutoFilterMode = False
             .UsedRange.AutoFilter Field:=2, Criteria1:=Array1()
             .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
             .AutoFilterMode = False
             .AutoFilterMode = False
             .UsedRange.AutoFilter Field:=Exceptions_Column, Criteria1:="1", Operator:=xlFilterValues
             .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
             .AutoFilterMode = False

           End With

有人可以推荐一个快速的方法来做到这一点。谢谢！！

Answer 1

Amatya，如果我理解正确，您想改进仅使用0s 即可获得所有结果的部分。

在这种情况下，我建议先复制工作表，然后像这样过滤它

Option Explicit

Sub Main()
Application.ScreenUpdating = False
    AddWorksheet
    FilterResults
Application.ScreenUpdating = True
End Sub

Private Sub AddWorksheet()
    Sheets(1).Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Working Copy"
End Sub

Private Sub FilterResults()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets(Sheets.Count)
    lastRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
    Set rng = ws.Range("A1:C" & lastRow)

    ' filter and delete all but header row
    With rng
        .AutoFilter Field:=3, Criteria1:="<>0"
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    ws.AutoFilterMode = False
End Sub

在一个新的工作簿中，我设置了一个这样的示例数据（Sheet1）

然后运行代码并在最后得到一个名为 "Working Copy" 的新工作表，结果如下

注意：公平地说，我不知道过滤结果的更快方法。我创建了一个新工作表而不是复制粘贴范围，这要慢得多。然后应用过滤器删除所有行的第 3 列（C 列）不等于 0。

这运行速度超快

10,000 行只用了 1 秒，所以还是很快的