Сохраните настройки автофильтра и повторно примените - PullRequest
Новая
       9

Сохраните настройки автофильтра и повторно примените

0 голосов
/ 29 марта 2019

У меня есть две таблицы 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

Ответы [ 3 ]

1 голос
/ 29 марта 2019

Если вы говорите о таблицах, это не отфильтрованные диапазоны, это 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-УВА /

0 голосов
/ 29 марта 2019

Я надеюсь, что есть лучший ответ, чем этот, но он может помочь, если вы не нашли ничего, что работает.Предустановленные фильтры останутся прежними: 

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
0 голосов
/ 29 марта 2019

Если автофильтр не включен, то 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
...