在Excel VBA中获取日期自动过滤器 [英] Get Date Autofilter in Excel VBA
本文介绍了在Excel VBA中获取日期自动过滤器的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
任何人可以帮我获取Autofilter参数，特别是在应用日期Autofilter时？
例如假设您有一个包含两列的表，一个包含文本数据，另一个包含日期数据。
将文本过滤器设置为第一个列：
Range.Autofilter字段：= 1，Criteria1 = Array（text1 ，text2，text3，text4），运算符：= xlFilterValues
获取过滤器信息，您可以循环通过Criteria1 Variant Array（从1索引）获取每个过滤器，如i = 1到4：
Print Range.Autofilter.Filters（1）.Criteria1（i）
现在第二列表示已设置日期过滤器：
Range.AutoFilter字段：= 2，运算符：= xlFilterValues，Criteria2：= Array（2，8/10/2015，2，8/20/2015）
如果我们遵循文本过滤器的相同逻辑，我希望我们可以从Criteria2属性中的变量数组获取过滤器信息，但是这个语句会产生错误（1004：应用程序定义或对象定义的错误） ，而您期望整数2作为输出：
P rint Range.Autofilter.Filters（2）.Criteria2（1）
解决方案
我已经走了一个相当长的方法，但它似乎是唯一的方法我可以找到这样做。
通过从xlsx文件中提取xml数据获取过滤器信息，存储在某处，稍后在同一个然后可以通过将xml转换为VBA AutoFilter函数来应用过滤器。工作代码如下：
将自动过滤器解压缩为xml字符串。函数输入是一个表，但可以修改为采取一个范围：
函数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 - 无法从VBA中提取日期过滤器（Criteria2数组）。从XML中保存过滤器，并解释实现
'XlAutoFilterOperator枚举（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
打开错误Resume Next
tableFilterOn = tbl.AutoFilter.FilterMode
On Error GoTo 0
如果tableFilterOn然后
对于fi = 1 To tbl.AutoFilter.Filters.Count
设置f = tbl.AutoFilter.Filters（fi）
如果f.On然后
hasFilterOn = True
退出
结束如果
下一个
如果hasFilterOn然后
Dim fn As Variant，xmlFn As Variant，zippedFn As Variant，workFolder As Variant，thisGUID As String
thisGUID =GUID
w orkingFolder = Environ（temp）
fn = workingFolder& \&这个GUID& .xlsx.zip
xmlFn =table1.xml
zippedFn =xl\tables\& xmlFn
'保存为temp为xlsx
'Application.Visible = False
Err = 0
错误恢复下一步
ThisWorkbook。 Sheets（Array（_
tbl.Range.Worksheet.Name _
））。复制
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fn，xlOpenXMLWorkbook
ActiveWorkbook。关闭
Application.DisplayAlerts = True
'Application.Visible = True
如果Err.Number<> 0然后
MsgBox（获取过滤器设置错误）
退出函数
结束如果
错误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
设置objShell = CreateObject（Shell.Application）
设置ns = objShell.Namespace（fn）
'创建对ZIP文件中的文件和文件夹的引用
设置objSource = ns。 Items.Item（zippedFn）
'创建对目标文件夹的引用
设置objTarget = objShell.Namespace（workingFolder）
'UnZIP文件
'选项参考：https：/ /msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v = vs85）.aspx
intOptions = 16
objTarget.CopyHere objSource，intOptions
'释放对象
设置objSource = Nothing
设置objTarget = Nothing
设置objShell =没有
'提取过滤器信息
Dim xmlData As String
打开workingFolder& \& xmlFn对于二进制访问读为1
xmlData =空格（LOF（1））
获取1，1，xmlData
关闭1
Dim endTag As Long，startTag As Long
startTag = InStr（1，xmlData，< autoFilter）
如果startTag> 0然后
xmlData = Right（xmlData，Len（xmlData） - startTag + 1）
endTag = InStr（1，xmlData，< / autoFilter>）
xmlData = Left（xmlData ，endTag + Len（< / autoFilter>） - 1）
结束如果
'删除临时文件
错误恢复下一步
杀死fn
Kill workingFolder& \& xmlFn
错误GoTo 0
tmpStr = xmlData
'没有列名称，但稍后我需要这样做，所以添加它们
Dim c As Long
c = 1
对于c = 1 To tbl.AutoFilter.Range.Rows（1）.Cells.Count
tmpStr =替换（tmpStr，filterColumn colId = & c - 1&，filterColumn colId =& c - 1&colName =& tbl.HeaderRowRange.Cells（1，c）.value& ）
下一个
如果
结束If
TableFilterToString = tmpStr结束函数
然后，稍后应用过滤器，将range和xml字符串输入到此函数中。不适应颜色和图标过滤，但如果这成为需求，可以扩展。
Sub ApplyXmlAutoFilter（autoFilterRange As Range， strXML As String）
'XlAutoFilterOperator枚举（Excel）
'https://msdn.microsoft.com/en-us/library/office/ff839625.aspx
'info日期自动过滤器：
'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
'还有，顶部的sml.xsd里面的zip下载
'清除现有的自动过滤器
autoFilterRange.AutoFilter
如果strXML =then
Exit Sub
End If
Dim objXML As Object
Dim baseNode As Object，filterColNode As对象，filtersNode作为对象，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
设置objXML = CreateObject（MSXML.DOMDocument）
如果不是objXML。 LoadXML（strXML）然后'strXML是带有XML的字符串'
Err.Raise objXML.parseError.ErrorCode，objXML.parseError.reason
End If
'XMLDom ref： https://msdn.microsoft.com/en-us/library/aa468547.aspx
如果objXML.HasChildNodes然后
对于每个baseNode在objXML.ChildNodes
如果baseNode。 HasChildNodes然后
对于每个filterColNode在baseNode.ChildNodes
colId = CLng（filterColNode.getattribute（colId））+ 1'xml是0索引，所以增加1
colName = filterColNode.getattribute（colName）
'如果名称存在于该范围内，则使用匹配的名称覆盖colId
matchFound = Application.Match（colName，autoFilterRange.Rows 1），0）
如果不是IsError（matchFound）然后
'只应用过滤器如果找到相同的列
colId = matchFound
'重置过滤器变量
numCriteria1 = 0
numCriteria2 = 0
filterOperator = 0
ReDim criteria1Array（999）
ReDim criteria2Array（999）
criteriaStr =
dynamicFilter = 0
如果filterColNode.HasChildNodes然后
对于每个filtersNode在filterColNode.C hildNodes
如果filtersNode.getattribute（blank）=1则
criteria1Array（numCriteria1）==
numCriteria1 = numCriteria1 + 1
如果
选择案例filtersNode.nodename
案例colorFilter
'将需要从原始XML抓取任何dxfId是
'如果filterDetailNode.getattribute（cellColor）=false 然后
'filterOperator = xlFilterCellColor
'Else
'filterOperator = xlFilterFontColor
'End If
'criteria1Array（numCriteria1 ）= filterDetailNode.getattribute（dxfId）
'numCriteria1 = numCriteria1 + 1
案例dynamicFilter
filterOperator = xlFilterDynamic
'val\valISO\maxValIso - 貌似这些属性可以忽略，因为过滤器是动态的...
'不知道null，所以只有已知过滤器的代码
'ref XlDynamicFilterCriteria枚举：https://msdn.microsoft.com/en -us / library / bb241234（v = office.12）.aspx
选择案例filtersNode.getattribute（type）
案例null
'dynamicFilter = ???
案例aboveAverage
dynamicFilter = xlFilterAboveAverage
案例belowAverage
dynamicFilter = xlFilterBelowAverage
案例明天
dynamicFilter = xlFilterTomorrow
案例今天
dynamicFilter = xlFilterToday
案例昨天
dynamicFilter = xlFilterYesterday
案例nextWeek
dynamicFilter = xlFilterNextWeek
案例thisWeek
dynamicFilter = xlFilterThisWeek
案例lastWeek
dynamicFilter = xlFilterLastWeek
案例nextMonth
dynamicFilter = xlFilterNextMonth
案例thisMonth
dynamicFilter = xlFilterThisMonth
案例lastMonth
dynamicFilter = xlFilterLastMonth
案例nextQuarter
dynamicFilter = xlFilterNextQuarter
案例thisQuarter
dynamicFilter = xlFilterThisQuarter
caselastQuarter
dynamicFilter = xlFilterLastQuarter
案例nextYear
dynamicFilter = xlFilterNextYear
案例thisYear
dynamicFilter = xlFilterThisYear
案例lastYear
dynamicFilter = xlFilterLastYear
案例yearToDate
dynamicFilter = xlFilterYearToDate
案例Q1
dynamicFilter = xlFilterAllDatesInPeriodQuarter1
案例Q2
dynamicFilter = xlFilterAllDatesInPeriodQuarter2
案例Q3
dynamicFilter = xlFilterAllDatesInPeriodQuarter3
案例Q4
dynamicFilter = xlFilterAllDatesInPeriodQuarter4
案例M1
dynamicFilter = xlFilterAllDatesInPeriodJanuary
案例M2
dynamicFilter = xlFilterAllDatesInPeriodFebruray
案例M3
dynamicFilter = xlFilterAllDatesInPeriodMarch
案例M4
动态过滤器= xlFilterAllDatesInPeriodApril
案例M5
dynamicFilter = xlFilterAllDatesInPeriodMay
案例M6
dynamicFilter = xlFilterAllDatesInPeriodJune
案例M7
dynamicFilter = xlFilterAllDatesInPeriodJuly
案例M8
dynamicFilter = xlFilterAllDatesInPeriodAugust
案例M9
dynamicFilter = xlFilterAllDatesInPeriodSeptember
案例M10
dynamicFilter = xlFilterAllDatesInPeriodOctober
案例M11
dynamicFilter = xlFilterAllDatesInPeriodNovember
案例M12
dynamicFilter = xlFilterAllDatesInPeriodDecember
结束选择
如果dynamicFilter> 0然后
criteria1Array（numCriteria1）= dynamicFilter
numCriteria1 = numCriteria1 + 1
End If
Case Else
对于每个filterDetailNode在filtersNode.ChildNodes
选择案例filterDetailNode.nodename
casefilter
'normal filter
filterOperator = xlFilterValues
criteria1Array（numCriteria1）= filterDetailNode.getattribute（val）
numCriteria1 = numCriteria1 + 1
案例customFilter
选择Case filterDetailNode.getattribute（operator）
案例等于
criteriaStr ==
案例lessThan
criteriaStr =<
案例lessThanOrEqual
criteriaStr =< =
案例notEqual
criteriaStr =<>
案例greaterThanOrEqual
criteriaStr => =
案例greaterThan
criteriaStr =>
Case Else
criteriaStr =
filterOperator = xlAnd
结束选择
criteriaStr = criteriaStr& filterDetailNode.getattribute（val）
如果numCriteria1 = 0然后
criteria1Array（numCriteria1）= criteriaStr
numCriteria1 = numCriteria1 + 1
Else
如果filterDetailNode.getattribute（and）=1然后
filterOperator = xlAnd
Else
filterOperator = xlOr
End If
criteria2Array（numCriteria2） = criteriaStr
numCriteria2 = numCriter ia2 + 1
结束如果
案例dateGroupItem
'日期上的信息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
'始终以美式格式应用字符串，m / d / yyyy或m / d / yyyy H：m：s
filterOperator = xlFilterValues
选择案例filterDetailNode.getattribute（dateTimeGrouping）
案例year
criteria2Array（numCriteria2）= 0
criteria2Array（numCriteria2 + 1）=1/1 /& filterDetailNode.getattribute（year）
numCriteria2 = numCriteria2 + 2
案例month
criteria2Array（numCriteria2）= 1
criteria2Array（numCriteria2 + 1）= filterDetailNode.getattribute 月）& / 1 /& filterDetailNode.getattribute（year）
numCriteria2 = numCriteria2 + 2
案例day
criteria2Array（numCriteria2）= 2
criteria2Array（numCriteria2 + 1）= filterDetailNode.getattribute 月）& /& filterDetailNode.getattribute（day）& /& filterDetailNode.getattribute（year）
numCriteria2 = numCriteria2 + 2
案例小时
criteria2Array（numCriteria2）= 3
criteria2Array（numCriteria2 + 1）= filterDetailNode.getattribute 月）& /& filterDetailNode.getattribute（day）& /& filterDetailNode.getattribute（year）_
& & filterDetailNode.getattribute（hour）& ：0：0
numCriteria2 = numCriteria2 + 2
案例分钟
criteria2Array（numCriteria2）= 4
criteria2Array（numCriteria2 + 1）= filterDetailNode.getattribute ）& /& filterDetailNode.getattribute（day）& /& filterDetailNode.getattribute（year）_
& & filterDetailNode.getattribute（hour）& ：& filterDetailNode.getattribute（minute）& ：0
numCriteria2 = numCriteria2 + 2
案例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
结束选择
结束选择
下一个'为每个filterDetailNode在filtersNode.ChildNodes
结束选择
'apply filters
如果filterOperator = xlAnd或filterOperator = xlOr或filterOperator = xlFilterDynamic然后
如果numCriteria2> 0然后
autoFilterRange.AutoFilter _
字段：= colId，_
Criteria1：= criteria1Array（0），_
Criteria2：= criteria2Array（0），_
运算符：= filterOperator
Else
autoFilterRange.AutoFilter _
Field：= colId，_
Criteria1：= criteria1Array（0），_
运算符：= filterOperator
End If
ElseIf numCriteria1> 0和numCriteria2> 0然后
ReDim保留条件1Array（numCriteria1 - 1）
ReDim保留条件2Array（numCriteria2 - 1）
如果filterOperator = 0然后
autoFilterRange.AutoFilter _
字段：= colId，_
Criteria1：= Array（criteria1Array），_
Criteria2：= Array（criteria2Array）
Else
autoFilterRange.AutoFilter _
Field：= colId，_
Criteria1：= Array（criteria1Array），_
Criteria2：= Array（criteria2Array），_
运算符：= filterOperator
End If
ElseIf numCriteria1> 0然后
ReDim Preserve criteria1Array（numCriteria1 - 1）
如果filterOperator = 0然后
autoFilterRange.AutoFilter字段：= colId，Criteria1：= Array（criteria1Array）
Else
autoFilterRange.AutoFilter字段：= colId，Criteria1：= Array（criteria1Array），Operator：= filterOperator
End If
ElseIf numCriteria2> 0然后
ReDim保留条件2Array（numCriteria2 - 1）
如果filterOperator = 0然后
autoFilterRange.AutoFilter字段：= colId，Criteria2：= Array（criteria2Array）
Else
autoFilterRange.AutoFilter字段：= colId，Criteria2：= Array（criteria2Array），Operator：= filterOperator
End If
End If
Next
End If'filterColNode .HasChildNodes
End If'Not IsError（matchFound）
Next'对于每个filterColNode在baseNode.ChildNodes
End If'baseNode.HasChildNodes
Next'对于每个baseNode在objXML.ChildNodes
End If'objXML.HasChildNodes
End Sub
结束
I am trying to extract Autofilter parameters using VBA.
Can any one help me with getting the Autofilter parameters, specifically when a date Autofilter is applied?
E.g. Say you have a table with two columns, one contains text data, and a second contains date data.
To set text filter to the first colum:
Range.Autofilter Field:=1, Criteria1=Array("text1","text2","text3","text4"), Operator:=xlFilterValues
Then to get the filter information you can loop through the Criteria1 Variant Array (indexed from 1) to get each filter, as in for i = 1 to 4:
Print Range.Autofilter.Filters(1).Criteria1(i)
Now for column two say a date filter has been set:
Range.AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(2, "8/10/2015", 2, "8/20/2015")
If we follow the same logic for the text filter, I'd expect we could get the filter information from a variant array in the Criteria2 property, but this statement will produce an error (1004: Application-defined or object-defined error), whereas you'd expect the integer '2' to be the output:
Print Range.Autofilter.Filters(2).Criteria2(1)
解决方案
I've gone with a rather long-winded approach, but it seems the only way I can find to do it.
Get filter info by extract xml data from xlsx file, store that somewhere, later on the same filter can then be applied by converting the xml into the VBA AutoFilter function. Working code as follows:
Extract autofilter as an xml string. The functions input is a table, but could be modified to take a Range:
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
Then, to later on apply the filter, input the range and xml string into this function. Does not cater to color and icon filtering, but could be expanded if this became a requirement.
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
Ends
这篇关于在Excel VBA中获取日期自动过滤器的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
