Получить автофильтр даты в Excel VBA

Question

Я пытаюсь извлечь параметры Autofilter с помощью VBA. Может ли кто-нибудь помочь мне с получением параметров Autofilter, особенно когда применяется дата Autofilter? . Скажем, у вас есть таблица с двумя столбцами, одна содержит текстовые данные, а вторая содержит данные даты.
Чтобы установить текстовый фильтр для первой Colum:

Range.Autofilter Field:=1, Criteria1=Array("text1","text2","text3","text4"), Operator:=xlFilterValues 

Затем, чтобы получить информацию фильтра вы можете цикл через массив факторам1 Variant (индексируется с 1), чтобы получить каждый фильтр, как для я = 1 до 4:

Print Range.Autofilter.Filters(1).Criteria1(i) 

Теперь второй колонке говорят дата фильтр установлен:

Range.AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(2, "8/10/2015", 2, "8/20/2015") 

Если следовать той же логике, для текстового фильтра, я ожидаю, что мы могли бы получить фильтр я nformation из массива вариантов в свойстве Criteria2, но этот оператор будет вызывать ошибку (1004: Определенная приложением или объектно-ориентированная ошибка), тогда как вы ожидаете, что целое число «2» будет выводимым:

Print Range.Autofilter.Filters(2).Criteria2(1) 

Answer 1

Я пошел с довольно долгим подходом, но, кажется, единственный способ найти это.
Получить информацию о фильмах извлечения данных xml из файла xlsx, сохранить их где-нибудь, позже в том же самом фильтре, затем можно применить, преобразовывая xml в функцию VBA AutoFilter. Рабочий код выглядит следующим образом:
Извлечь автофильтр в виде строки xml. Входные функции представляет собой таблицу, но может быть изменен, чтобы принять Диапазон:

Function TableFilterToString(tbl As ListObject) As String 
Dim tmpStr As String, f As Filter, i As Long, fi As Long 
Dim hasFilterOn As Boolean, tableFilterOn As Boolean 

'bleh - cannot extract date filters from VBA (Criteria2 array). Save filters from XML instead, and interpret on implementation 

'XlAutoFilterOperator Enumeration (Excel) 
'https://msdn.microsoft.com/en-us/library/office/ff839625.aspx 

'info on date autofilters: 
'http://answers.microsoft.com/en-us/office/forum/office_2007-customize/autofilter-criteria-with-xlfiltervalues-and-dates/90da7c5a-c813-4182-9849-c57ab72dac63?auth=1 

tmpStr = "" 
fi = 1 
Err.Number = 0 
On Error Resume Next 
tableFilterOn = tbl.AutoFilter.FilterMode 
On Error GoTo 0 

If tableFilterOn Then 
    For fi = 1 To tbl.AutoFilter.Filters.Count 
     Set f = tbl.AutoFilter.Filters(fi) 
     If f.On Then 
      hasFilterOn = True 
      Exit For 
     End If 
    Next 

    If hasFilterOn Then 
     Dim fn As Variant, xmlFn As Variant, zippedFn As Variant, workingFolder As Variant, thisGUID As String 
     thisGUID = "GUID" 
     workingFolder = Environ("temp") 
     fn = workingFolder & "\" & thisGUID & ".xlsx.zip" 
     xmlFn = "table1.xml" 
     zippedFn = "xl\tables\" & xmlFn 

     'save to temp as xlsx 
     'Application.Visible = False 
     Err = 0 
     On Error Resume Next 

     ThisWorkbook.Sheets(Array(_ 
      tbl.Range.Worksheet.Name _ 
      )).Copy 
     Application.DisplayAlerts = False 
     ActiveWorkbook.SaveAs fn, xlOpenXMLWorkbook 
     ActiveWorkbook.Close 
     Application.DisplayAlerts = True 
     'Application.Visible = True 

     If Err.Number <> 0 Then 
      MsgBox ("Error getting filter settings") 
      Exit Function 
     End If 
     On Error GoTo 0 

     'extract table1.xml 
     'http://stackoverflow.com/questions/19716587/how-to-open-a-file-from-an-archive-in-vba-without-unzipping-the-archive 
     'http://www.rondebruin.nl/win/s7/win002.htm 
     Dim intOptions As Variant, objShell As Object, objSource As Object, objTarget As Object 
     Dim ns As Object 

     Set objShell = CreateObject("Shell.Application") 
     Set ns = objShell.Namespace(fn) 
     ' Create a reference to the files and folders in the ZIP file 
     Set objSource = ns.Items.Item(zippedFn) 
     ' Create a reference to the target folder 
     Set objTarget = objShell.Namespace(workingFolder) 
     ' UnZIP the files 
     'options ref: https://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx 
     intOptions = 16 
     objTarget.CopyHere objSource, intOptions 
     ' Release the objects 
     Set objSource = Nothing 
     Set objTarget = Nothing 
     Set objShell = Nothing 


     'extract filter info 
     Dim xmlData As String 
     Open workingFolder & "\" & xmlFn For Binary Access Read As 1 
      xmlData = Space(LOF(1)) 
      Get 1, 1, xmlData 
     Close 1 

     Dim endTag As Long, startTag As Long 
     startTag = InStr(1, xmlData, "<autoFilter") 
     If startTag > 0 Then 
      xmlData = Right(xmlData, Len(xmlData) - startTag + 1) 
      endTag = InStr(1, xmlData, "</autoFilter>") 
      xmlData = Left(xmlData, endTag + Len("</autoFilter>") - 1) 
     End If 

     'delete temp files 
     On Error Resume Next 
     Kill fn 
     Kill workingFolder & "\" & xmlFn 
     On Error GoTo 0 

     tmpStr = xmlData 

     'dont have column names, but I will need this later, so add them in. 
     Dim c As Long 
     c = 1 
     For c = 1 To tbl.AutoFilter.Range.Rows(1).Cells.Count 
      tmpStr = Replace(tmpStr, "filterColumn colId=""" & c - 1 & """", "filterColumn colId=""" & c - 1 & """ colName=""" & tbl.HeaderRowRange.Cells(1, c).value & """") 
     Next 
    End If 
End If 

TableFilterToString = tmpStr End Function 

Затем, чтобы в дальнейшем применить фильтр, входной строки диапазона и XML в эту функцию. Не поддерживает фильтрацию цветов и значков, но может быть расширена, если это станет требованием.

Sub ApplyXmlAutoFilter(autoFilterRange As Range, strXML As String) 
    'XlAutoFilterOperator Enumeration (Excel) 
    'https://msdn.microsoft.com/en-us/library/office/ff839625.aspx 

    'info on date autofilters: 
    'http://answers.microsoft.com/en-us/office/forum/office_2007-customize/autofilter-criteria-with-xlfiltervalues-and-dates/90da7c5a-c813-4182-9849-c57ab72dac63?auth=1 

    'refs on autofilter xml schema 
    'http://www.ecma-international.org/publications/standards/Ecma-376.htm 
    'autofilters: part1 p.3859 
    'also, top of sml.xsd inside the zip download 

    'clear existing autofilter 
    autoFilterRange.AutoFilter 

    If strXML = "" Then 
     Exit Sub 
    End If 

    Dim objXML As Object 
    Dim baseNode As Object, filterColNode As Object, filtersNode As Object, filterDetailNode As Object 
    Dim matchFound As Variant 
    Dim colId As Long, colName As String, filterOperator As Integer, dynamicFilter As Integer 
    Dim criteria1Array() As Variant, criteria2Array() As Variant, numCriteria1 As Long, numCriteria2 As Long 
    Dim criteriaStr As String 

    Set objXML = CreateObject("MSXML.DOMDocument") 

    If Not objXML.LoadXML(strXML) Then 'strXML is the string with XML' 
     Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason 
    End If 

    'XMLDom ref: https://msdn.microsoft.com/en-us/library/aa468547.aspx 

    If objXML.HasChildNodes Then 
     For Each baseNode In objXML.ChildNodes 
      If baseNode.HasChildNodes Then 
       For Each filterColNode In baseNode.ChildNodes 
        colId = CLng(filterColNode.getattribute("colId")) + 1 'xml is 0-indexed, so increase by 1 
        colName = filterColNode.getattribute("colName") 
        'if the name exists in the range, then overwrite the colId with the matching name 
        matchFound = Application.Match(colName, autoFilterRange.Rows(1), 0) 
        If Not IsError(matchFound) Then 
         'only apply filter if same column is found 
         colId = matchFound 

         'reset filter variables 
         numCriteria1 = 0 
         numCriteria2 = 0 
         filterOperator = 0 
         ReDim criteria1Array(999) 
         ReDim criteria2Array(999) 
         criteriaStr = "" 
         dynamicFilter = 0 

         If filterColNode.HasChildNodes Then 
          For Each filtersNode In filterColNode.ChildNodes 
           If filtersNode.getattribute("blank") = "1" Then 
            criteria1Array(numCriteria1) = "=" 
            numCriteria1 = numCriteria1 + 1 
           End If 

           Select Case filtersNode.nodename 
            Case "colorFilter" 
             'will need to extrapolate from original XML grab what dxfId is 
'          If filterDetailNode.getattribute("cellColor") = "false" Then 
'           filterOperator = xlFilterCellColor 
'          Else 
'           filterOperator = xlFilterFontColor 
'          End If 
'          criteria1Array(numCriteria1) = filterDetailNode.getattribute("dxfId") 
'          numCriteria1 = numCriteria1 + 1 
            Case "dynamicFilter" 
             filterOperator = xlFilterDynamic 
             'val\valISO\maxValIso - seemingly these attributes can be ignored, as the filter is dynamic anyway... 
             'not sure about null, so only code for known filters 
             'ref XlDynamicFilterCriteria enumeration: https://msdn.microsoft.com/en-us/library/bb241234(v=office.12).aspx 
             Select Case filtersNode.getattribute("type") 
              Case "null" 
               'dynamicFilter = ??? 
              Case "aboveAverage" 
               dynamicFilter = xlFilterAboveAverage 
              Case "belowAverage" 
               dynamicFilter = xlFilterBelowAverage 
              Case "tomorrow" 
               dynamicFilter = xlFilterTomorrow 
              Case "today" 
               dynamicFilter = xlFilterToday 
              Case "yesterday" 
               dynamicFilter = xlFilterYesterday 
              Case "nextWeek" 
               dynamicFilter = xlFilterNextWeek 
              Case "thisWeek" 
               dynamicFilter = xlFilterThisWeek 
              Case "lastWeek" 
               dynamicFilter = xlFilterLastWeek 
              Case "nextMonth" 
               dynamicFilter = xlFilterNextMonth 
              Case "thisMonth" 
               dynamicFilter = xlFilterThisMonth 
              Case "lastMonth" 
               dynamicFilter = xlFilterLastMonth 
              Case "nextQuarter" 
               dynamicFilter = xlFilterNextQuarter 
              Case "thisQuarter" 
               dynamicFilter = xlFilterThisQuarter 
              Case "lastQuarter" 
               dynamicFilter = xlFilterLastQuarter 
              Case "nextYear" 
               dynamicFilter = xlFilterNextYear 
              Case "thisYear" 
               dynamicFilter = xlFilterThisYear 
              Case "lastYear" 
               dynamicFilter = xlFilterLastYear 
              Case "yearToDate" 
               dynamicFilter = xlFilterYearToDate 
              Case "Q1" 
               dynamicFilter = xlFilterAllDatesInPeriodQuarter1 
              Case "Q2" 
               dynamicFilter = xlFilterAllDatesInPeriodQuarter2 
              Case "Q3" 
               dynamicFilter = xlFilterAllDatesInPeriodQuarter3 
              Case "Q4" 
               dynamicFilter = xlFilterAllDatesInPeriodQuarter4 
              Case "M1" 
               dynamicFilter = xlFilterAllDatesInPeriodJanuary 
              Case "M2" 
               dynamicFilter = xlFilterAllDatesInPeriodFebruray 
              Case "M3" 
               dynamicFilter = xlFilterAllDatesInPeriodMarch 
              Case "M4" 
               dynamicFilter = xlFilterAllDatesInPeriodApril 
              Case "M5" 
               dynamicFilter = xlFilterAllDatesInPeriodMay 
              Case "M6" 
               dynamicFilter = xlFilterAllDatesInPeriodJune 
              Case "M7" 
               dynamicFilter = xlFilterAllDatesInPeriodJuly 
              Case "M8" 
               dynamicFilter = xlFilterAllDatesInPeriodAugust 
              Case "M9" 
               dynamicFilter = xlFilterAllDatesInPeriodSeptember 
              Case "M10" 
               dynamicFilter = xlFilterAllDatesInPeriodOctober 
              Case "M11" 
               dynamicFilter = xlFilterAllDatesInPeriodNovember 
              Case "M12" 
               dynamicFilter = xlFilterAllDatesInPeriodDecember 
             End Select 

             If dynamicFilter > 0 Then 
              criteria1Array(numCriteria1) = dynamicFilter 
              numCriteria1 = numCriteria1 + 1 
             End If 
            Case Else 
             For Each filterDetailNode In filtersNode.ChildNodes 
              Select Case filterDetailNode.nodename 
               Case "filter" 
                'normal filter 
                filterOperator = xlFilterValues 
                criteria1Array(numCriteria1) = filterDetailNode.getattribute("val") 
                numCriteria1 = numCriteria1 + 1 

               Case "customFilter" 
                Select Case filterDetailNode.getattribute("operator") 
                 Case "equal" 
                  criteriaStr = "=" 
                 Case "lessThan" 
                  criteriaStr = "<" 
                 Case "lessThanOrEqual" 
                  criteriaStr = "<=" 
                 Case "notEqual" 
                  criteriaStr = "<>" 
                 Case "greaterThanOrEqual" 
                  criteriaStr = ">=" 
                 Case "greaterThan" 
                  criteriaStr = ">" 
                 Case Else 
                  criteriaStr = "" 
                  filterOperator = xlAnd 
                End Select 
                criteriaStr = criteriaStr & filterDetailNode.getattribute("val") 

                If numCriteria1 = 0 Then 
                 criteria1Array(numCriteria1) = criteriaStr 
                 numCriteria1 = numCriteria1 + 1 
                Else 
                 If filterDetailNode.getattribute("and") = "1" Then 
                  filterOperator = xlAnd 
                 Else 
                  filterOperator = xlOr 
                 End If 

                 criteria2Array(numCriteria2) = criteriaStr 
                 numCriteria2 = numCriteria2 + 1 
                End If 

               Case "dateGroupItem" 
                'info on date autofilters: 
                'http://answers.microsoft.com/en-us/office/forum/office_2007-customize/autofilter-criteria-with-xlfiltervalues-and-dates/90da7c5a-c813-4182-9849-c57ab72dac63?auth=1 
                'always apply string in American formats, either m/d/yyyy or m/d/yyyy H:m:s 
                filterOperator = xlFilterValues 
                Select Case filterDetailNode.getattribute("dateTimeGrouping") 
                 Case "year" 
                  criteria2Array(numCriteria2) = 0 
                  criteria2Array(numCriteria2 + 1) = "1/1/" & filterDetailNode.getattribute("year") 
                  numCriteria2 = numCriteria2 + 2 
                 Case "month" 
                  criteria2Array(numCriteria2) = 1 
                  criteria2Array(numCriteria2 + 1) = filterDetailNode.getattribute("month") & "/1/" & filterDetailNode.getattribute("year") 
                  numCriteria2 = numCriteria2 + 2 
                 Case "day" 
                  criteria2Array(numCriteria2) = 2 
                  criteria2Array(numCriteria2 + 1) = filterDetailNode.getattribute("month") & "/" & filterDetailNode.getattribute("day") & "/" & filterDetailNode.getattribute("year") 
                  numCriteria2 = numCriteria2 + 2 
                 Case "hour" 
                  criteria2Array(numCriteria2) = 3 
                  criteria2Array(numCriteria2 + 1) = filterDetailNode.getattribute("month") & "/" & filterDetailNode.getattribute("day") & "/" & filterDetailNode.getattribute("year") _ 
                   & " " & filterDetailNode.getattribute("hour") & ":0:0" 
                  numCriteria2 = numCriteria2 + 2 
                 Case "minute" 
                  criteria2Array(numCriteria2) = 4 
                  criteria2Array(numCriteria2 + 1) = filterDetailNode.getattribute("month") & "/" & filterDetailNode.getattribute("day") & "/" & filterDetailNode.getattribute("year") _ 
                   & " " & filterDetailNode.getattribute("hour") & ":" & filterDetailNode.getattribute("minute") & ":0" 
                  numCriteria2 = numCriteria2 + 2 
                 Case "second" 
                  criteria2Array(numCriteria2) = 5 
                  criteria2Array(numCriteria2 + 1) = filterDetailNode.getattribute("month") & "/" & filterDetailNode.getattribute("day") & "/" & filterDetailNode.getattribute("year") _ 
                   & " " & filterDetailNode.getattribute("hour") & ":" & filterDetailNode.getattribute("minute") & ":" & filterDetailNode.getattribute("second") 
                  numCriteria2 = numCriteria2 + 2 
                End Select 

              End Select 
             Next 'For Each filterDetailNode In filtersNode.ChildNodes 
           End Select 

           'apply filters 
           If filterOperator = xlAnd Or filterOperator = xlOr Or filterOperator = xlFilterDynamic Then 
            If numCriteria2 > 0 Then 
             autoFilterRange.AutoFilter _ 
              Field:=colId, _ 
              Criteria1:=criteria1Array(0), _ 
              Criteria2:=criteria2Array(0), _ 
              Operator:=filterOperator 
            Else 
             autoFilterRange.AutoFilter _ 
              Field:=colId, _ 
              Criteria1:=criteria1Array(0), _ 
              Operator:=filterOperator 
            End If 
           ElseIf numCriteria1 > 0 And numCriteria2 > 0 Then 
            ReDim Preserve criteria1Array(numCriteria1 - 1) 
            ReDim Preserve criteria2Array(numCriteria2 - 1) 
            If filterOperator = 0 Then 
             autoFilterRange.AutoFilter _ 
              Field:=colId, _ 
              Criteria1:=Array(criteria1Array), _ 
              Criteria2:=Array(criteria2Array) 
            Else 
             autoFilterRange.AutoFilter _ 
              Field:=colId, _ 
              Criteria1:=Array(criteria1Array), _ 
              Criteria2:=Array(criteria2Array), _ 
              Operator:=filterOperator 
            End If 
           ElseIf numCriteria1 > 0 Then 
            ReDim Preserve criteria1Array(numCriteria1 - 1) 
            If filterOperator = 0 Then 
             autoFilterRange.AutoFilter Field:=colId, Criteria1:=Array(criteria1Array) 
            Else 
             autoFilterRange.AutoFilter Field:=colId, Criteria1:=Array(criteria1Array), Operator:=filterOperator 
            End If 
           ElseIf numCriteria2 > 0 Then 
            ReDim Preserve criteria2Array(numCriteria2 - 1) 
            If filterOperator = 0 Then 
             autoFilterRange.AutoFilter Field:=colId, Criteria2:=Array(criteria2Array) 
            Else 
             autoFilterRange.AutoFilter Field:=colId, Criteria2:=Array(criteria2Array), Operator:=filterOperator 
            End If 
           End If 

          Next 
         End If 'filterColNode.HasChildNodes 
        End If 'Not IsError(matchFound) 
       Next 'For Each filterColNode In baseNode.ChildNodes 
      End If 'baseNode.HasChildNodes 
     Next 'For Each baseNode In objXML.ChildNodes 
    End If 'objXML.HasChildNodes 

End Sub 

Завершает

Answer 2

Я думаю, что вы исходная задача два раза. Во-первых, похоже, вы используете поле Criteria2 без Criteria1. Вы используете только Criteria2, когда хотите создать составные критерии, для которых требуется как аргумент Criteria1, так и аргумент XLAutoFilterOperator для объединения (например, xlAnd или xlOr) с аргументом Criteria2. В вашем примере, похоже, вы не указываете аргумент Criteria1.

Во-вторых, IIRC все критерии должны быть предоставлены в виде строки, которая, я считаю, является вторым примером, вызовет проблему с цифрами, которые вы пытаетесь передать.

Я удивлен, что вы действительно не получили ошибку на линии Autofilter.

Попробуйте изменить свой код:

Range.AutoFilter Field:=2, Criteria1:=Array(cstr(2), "8/10/2015", cstr(2), "8/20/2015"), Operator:=xlFilterValues 

Print Range.Autofilter.Filters(2).Criteria1(1) 

Answer 3

Эта проблема возникает, когда TreeView используется в селекторе фильтра относительно даты.

Рабочая альтернатива для восстановления автофильтров в этой ситуации объясняется в this post.