Get Date Autofilter in Excel VBA -
i trying extract autofilter parameters using vba. can 1 me getting autofilter parameters, when date autofilter applied? e.g. have table 2 columns, 1 contains text data, , second contains date data.
to set text filter first colum:
range.autofilter field:=1, criteria1=array("text1","text2","text3","text4"), operator:=xlfiltervalues then filter information can loop through criteria1 variant array (indexed 1) each filter, in = 1 4:
print range.autofilter.filters(1).criteria1(i) now column 2 date filter has been set:
range.autofilter field:=2, operator:=xlfiltervalues, criteria2:=array(2, "8/10/2015", 2, "8/20/2015") if follow same logic text filter, i'd expect filter information variant array in criteria2 property, statement produce error (1004: application-defined or object-defined error), whereas you'd expect integer '2' output:
print range.autofilter.filters(2).criteria2(1)
i've gone rather long-winded approach, seems way can find it.
get filter info extract xml data xlsx file, store somewhere, later on same filter can applied converting xml vba autofilter function. working code follows:
extract autofilter xml string. functions input table, modified take range:
function tablefiltertostring(tbl listobject) string dim tmpstr string, f filter, long, fi long dim hasfilteron boolean, tablefilteron boolean 'bleh - cannot extract date filters vba (criteria2 array). save filters xml instead, , 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 fi = 1 tbl.autofilter.filters.count set f = tbl.autofilter.filters(fi) if f.on hasfilteron = true exit end if next if hasfilteron dim fn variant, xmlfn variant, zippedfn variant, workingfolder variant, thisguid string thisguid = "guid" workingfolder = environ("temp") fn = workingfolder & "\" & thisguid & ".xlsx.zip" xmlfn = "table1.xml" zippedfn = "xl\tables\" & xmlfn 'save temp 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 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 variant, objshell object, objsource object, objtarget object dim ns object set objshell = createobject("shell.application") set ns = objshell.namespace(fn) ' create reference files , folders in zip file set objsource = ns.items.item(zippedfn) ' create reference target folder set objtarget = objshell.namespace(workingfolder) ' unzip files 'options ref: https://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx intoptions = 16 objtarget.copyhere objsource, intoptions ' release objects set objsource = nothing set objtarget = nothing set objshell = nothing 'extract filter info dim xmldata string open workingfolder & "\" & xmlfn binary access read 1 xmldata = space(lof(1)) 1, 1, xmldata close 1 dim endtag long, starttag long starttag = instr(1, xmldata, "<autofilter") if starttag > 0 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, need later, add them in. dim c long c = 1 c = 1 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, later on apply filter, input range , xml string function. not cater color , icon filtering, expanded if became requirement.
sub applyxmlautofilter(autofilterrange range, strxml 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 zip download 'clear existing autofilter autofilterrange.autofilter if strxml = "" exit sub end if dim objxml object dim basenode object, filtercolnode object, filtersnode object, filterdetailnode object dim matchfound variant dim colid long, colname string, filteroperator integer, dynamicfilter integer dim criteria1array() variant, criteria2array() variant, numcriteria1 long, numcriteria2 long dim criteriastr string set objxml = createobject("msxml.domdocument") if not objxml.loadxml(strxml) 'strxml string 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 each basenode in objxml.childnodes if basenode.haschildnodes each filtercolnode in basenode.childnodes colid = clng(filtercolnode.getattribute("colid")) + 1 'xml 0-indexed, increase 1 colname = filtercolnode.getattribute("colname") 'if name exists in range, overwrite colid matching name matchfound = application.match(colname, autofilterrange.rows(1), 0) if not iserror(matchfound) 'only apply filter if same column found colid = matchfound 'reset filter variables numcriteria1 = 0 numcriteria2 = 0 filteroperator = 0 redim criteria1array(999) redim criteria2array(999) criteriastr = "" dynamicfilter = 0 if filtercolnode.haschildnodes each filtersnode in filtercolnode.childnodes if filtersnode.getattribute("blank") = "1" criteria1array(numcriteria1) = "=" numcriteria1 = numcriteria1 + 1 end if select case filtersnode.nodename case "colorfilter" 'will need extrapolate original xml grab dxfid ' if filterdetailnode.getattribute("cellcolor") = "false" ' 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 ignored, filter dynamic anyway... 'not sure null, code 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 criteria1array(numcriteria1) = dynamicfilter numcriteria1 = numcriteria1 + 1 end if case else 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 criteria1array(numcriteria1) = criteriastr numcriteria1 = numcriteria1 + 1 else if filterdetailnode.getattribute("and") = "1" 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 if numcriteria2 > 0 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 , numcriteria2 > 0 redim preserve criteria1array(numcriteria1 - 1) redim preserve criteria2array(numcriteria2 - 1) if filteroperator = 0 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 redim preserve criteria1array(numcriteria1 - 1) if filteroperator = 0 autofilterrange.autofilter field:=colid, criteria1:=array(criteria1array) else autofilterrange.autofilter field:=colid, criteria1:=array(criteria1array), operator:=filteroperator end if elseif numcriteria2 > 0 redim preserve criteria2array(numcriteria2 - 1) if filteroperator = 0 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
Comments
Post a Comment