VBA在不同的工作簿中设置自动过滤器以选择所有列

Question

我将报表中的数据提取到 Excel 中，然后使用此代码验证是否打开了另一个工作簿（对于本示例，它将是“Swivel - Master - January 2016.xlsm”）。如果目标工作簿是打开的，那么 sub 会将有效数据复制到目标工作簿。目标工作簿已为 A:AE 列打开了过滤器。我需要做的是让子将所有过滤器更改为“全选”，以便在将有效数据复制到它之前没有隐藏行。我已经在 SO 中查找了这个，但我找不到任何与我正在寻找的东西相匹配的东西。我还录制了一个宏，看看它是否会起作用，但它没有。不知道如何做到这一点。提前感谢您的帮助。

Sub Extract_Sort_1601_January()

Dim ANS As Long

ANS = MsgBox("Is the January 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
If ANS = vbNo Or IsWBOpen("Swivel - Master - January 2016") = False Then
    MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
    Exit Sub
End If

Application.ScreenUpdating = False

    ' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

Dim LR As Long

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value <> "1" Then
            Rows(LR).EntireRow.Delete
        End If
    Next LR

With ActiveWorkbook.Worksheets("Extract").Sort
    With .SortFields
        .Clear
        .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range("A2:AE2000")
    .Apply
End With
Cells.WrapText = False
Sheets("Extract").Range("A2").Select

    Dim LastRow As Integer, i As Integer, erow As Integer

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow
        If Cells(i, 2) = "1" Then

            ' As opposed to selecting the cells, this will copy them directly
            Range(Cells(i, 1), Cells(i, 31)).Copy

            ' As opposed to "Activating" the workbook, and selecting the sheet, this will paste the cells directly
            With Workbooks("Swivel - Master - January 2016.xlsm").Sheets("Swivel")
                erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                .Cells(erow, 1).PasteSpecial xlPasteAll
            End With
            Application.CutCopyMode = False
        End If
    Next i

Application.ScreenUpdating = True
End Sub

Answer 1

将此代码放在循环之前以复制/粘贴（我认为）。

With Workbooks("Swivel - Master - January 2016.xlsm").Sheets("Swivel")
    erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    .Range("A1:AE" & erow).AutoFilter 'leaving arguments blank clears all filters, but leaves the drop-down arrows (filter mode still on)
End With

或者，如果打开 FilterMode 不是问题（意思是如果让它处于不出现过滤箭头的状态），只需执行以下操作：

Workbooks("Swivel - Master - January 2016.xlsm").Sheets("Swivel").AutoFilterMode = False