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

VBA将不同工作簿中的自动筛选设置为为所有列选择全部

1 个答案: