Question

我有两个Excel表，还有一个现有的宏，它从这些表之一（表A）中复制数据并将其粘贴到另一个表的底部（表B）。我发现，如果对表A进行了过滤，则此宏将无法工作，因为它表示无法从过滤后的表中复制数据。我想修改现有的宏，以使其首先复制任何过滤器（运行宏时，任何，全部或我的所有列均不过滤），然后将其删除，然后运行先前编程的活动，然后重新应用保存的过滤器，然后给我喝啤酒。不过，我会尽一切努力为我喝啤酒。

我认为这是一个常见问题，因此我搜索了一些可以放在现有代码开头和结尾的代码。我已经找到了以下内容，但是当我将其添加到现有代码中并运行宏时，在读取以下内容的早期行中出现错误： “ currentFiltRange = .Range.Address” 错误状态为“未设置对象变量或带块变量”。我是VBA的新手，不知道我复制的以下代码有什么问题。

Sub CopyThisWeekToRollupAndFilter()


    Dim w As Worksheet
    Dim filterArray()
    Dim currentFiltRange As String
    Dim col As Integer

    Set w = ActiveWorkbook.Sheets("Weekly")

    ' Capture AutoFilter settings
    With w.AutoFilter
        currentFiltRange = .Range.Address
        With .Filters
            ReDim filterArray(1 To .Count, 1 To 3)
            For f = 1 To .Count
                With .Item(f)
                    If .On Then
                        filterArray(f, 1) = .Criteria1
                        If .Operator Then
                            filterArray(f, 2) = .Operator
                            filterArray(f, 3) = .Criteria2 'simply delete this line to make it work in Excel 2010
                        End If
                    End If
                End With
            Next f
        End With
    End With

    'Remove AutoFilter
    w.AutoFilterMode = False

' Add my existing code here'

' Restore Filter settings
    For col = 1 To UBound(filterArray(), 1)
        If Not IsEmpty(filterArray(col, 1)) Then
            If filterArray(col, 2) Then
                w.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col, 1), _
                Operator:=filterArray(col, 2), _
                Criteria2:=filterArray(col, 3)
            Else
                w.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col, 1)
            End If
        End If
    Next col


End Sub

Answer 1

如果您谈论的是表格，它们不是过滤范围，而是ListObjects，您可以通过以下方式调用它们的范围

currentFiltRange = ActiveWorkbook.Sheets("Weekly").ListObjects("Table1").Range.Address

以下是为表提供VBA指南的链接： https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables

这里是您尝试的示例的链接： https://www.get-digital-help.com/2012/09/26/copy-excel-table-filter-criteria-vba/

Answer 2

如果未打开自动过滤器，则w.AutoFilter将是Nothing

您应该在代码中添加一个检查，以便首先查看过滤功能是否已启用

例如

isFiltered = Not w.AutoFilter Is Nothing

因此您可以跳过捕获/重新应用设置

编辑：

Sub CopyThisWeekToRollupAndFilter()


    Dim w As Worksheet
    Dim filterArray()
    Dim currentFiltRange As String
    Dim col As Integer, isFiltered As Boolean

    Set w = ActiveWorkbook.Sheets("Weekly")
    isFiltered = Not w.AutoFilter Is Nothing 

    If isFiltered Then
    ' Capture AutoFilter settings
    With w.AutoFilter
        currentFiltRange = .Range.Address
        With .Filters
            ReDim filterArray(1 To .Count, 1 To 3)
            For f = 1 To .Count
                With .Item(f)
                    If .On Then
                        filterArray(f, 1) = .Criteria1
                        If .Operator Then
                            filterArray(f, 2) = .Operator
                            filterArray(f, 3) = .Criteria2 'simply delete this line to make it work in Excel 2010
                        End If
                    End If
                End With
            Next f
        End With
    End With
    'Remove AutoFilter
    w.AutoFilterMode = False

    End If  'was filtered


' Add my existing code here'

    If isFiltered Then
    ' Restore Filter settings
    For col = 1 To UBound(filterArray(), 1)
        If Not IsEmpty(filterArray(col, 1)) Then
            If filterArray(col, 2) Then
                w.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col, 1), _
                Operator:=filterArray(col, 2), _
                Criteria2:=filterArray(col, 3)
            Else
                w.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col, 1)
            End If
        End If
    Next col
    End If 'was filtered


End Sub

Answer 3

我希望有比这更好的答案，但是如果您没有找到任何可行的方法，则可能会有所帮助。预设过滤器将保持不变：

Sub Hide_Unhide()
    Dim HiddenColumn() As Long
    Dim HiddenRow() As Long
    Dim colCounter As Long, rowCounter As Long, arrColLength As Long, arrRowLength As Long
    arrColLength = 0
    arrRowLength = 0

    Application.ScreenUpdating = False

    'Unhide columns
    For colCounter = 1 To ActiveSheet.UsedRange.Columns.Count
        If Columns(colCounter).Hidden = True Then
            arrColLength = arrColLength + 1
            ReDim Preserve HiddenColumn(1 To arrColLength)
            HiddenColumn(arrColLength) = colCounter
            Columns(colCounter).Hidden = False
        End If
    Next colCounter

    'Unhide rows
    For rowCounter = 1 To ActiveSheet.UsedRange.Rows.Count
        If Rows(rowCounter).Hidden = True Then
            arrRowLength = arrRowLength + 1
            ReDim Preserve HiddenRow(1 To arrRowLength)
            HiddenRow(arrRowLength) = rowCounter
            Rows(rowCounter).Hidden = False
        End If
    Next rowCounter

    'Your code here


    'apply hiddend columns
    For colCounter = 1 To arrColLength
        Columns(HiddenColumn(colCounter)).Hidden = True
    Next colCounter

    'apply hiddend rows
    For rowCounter = 1 To arrRowLength
        Rows(HiddenRow(rowCounter)).Hidden = True
    Next rowCounter

    Application.ScreenUpdating = True

End Sub

保存自动过滤器设置并重新应用

3 个答案: