Excel VBA在循环浏览filter时优化了速度
最终解决scheme编辑
首先，我很抱歉这花了这么长时间。 写完这篇文章之后不久，我就出城了，然后把这个项目拉下来，直到最近我能抽出时间去处理这个项目。
杰里给了我一个在行标签上使用组的好主意，而不是试图一次过滤一个date。 经过一些修改后，我能够以更快的速度满足我的需求。 最慢的时候，我把时间从5分钟缩短到45秒，而且随着时间的推移，我还想优化。 这是一个很好的方法，允许我更新几个相关的数据透视表。
对于那些可能会觉得有用的代码，请注意它包含了很多额外的function：
Sub Filter_PivotField_by_Dates(TargetPvtFld As PivotField, dtFrom As Date, dtTo As Date, _ Optional dtFrom2 As Date, Optional dtTo2 As Date) ' Filter the dates on all related pivoted tables via a grouping method. ' Variables ----- Dim bMultiRng As Boolean Dim iPvtTblRowCnt As Integer, iPvtTblColCnt As Integer, i As Integer, j As Integer, iGrpTrack As Integer, iSlcRowCnt As Integer Dim sarrPvtInfo() As String, sarrSlcInfo() As String Dim xCell As Range, rngGroup As Range, LastRw As Range, LastCol As Range Dim PvtFld As PivotField Dim Pvt As PivotTable Dim SlcItm As SlicerItem Dim SlcCache As SlicerCache Dim WS As Worksheet ' --------------- ' Disable application updating for speed. With Application .EnableEvents = False .Calculation = xlCalculationManual .ScreenUpdating = False End With ' First validate and determine whether or not it will be necessary to create a secondary comparison group. ' Ensure that something valid is entered for the pivot field value. If TargetPvtFld Is Nothing Then Msgbox "Invalid pivot field supplied to filter by date macro." Exit Sub Else On Error Resume Next Debug.Print "Target Pvt Field Name: " & TargetPvtFld.Name If Err.Number > 0 Then Debug.Print "Invalid pivot field supplied as target pivot field." Debug.Print " ----------------------------------" Err.Clear Exit Sub End If On Error GoTo 0 End If If dtFrom <= 0 Or dtTo <= 0 Then Debug.Print "Invalid dates fed to Filter Pivot by Date macro." Exit Sub ElseIf dtFrom > dtTo Then MsgBox "Please ensure that the starting date of comparison range 1 comes prior or equal to the ending date." Exit Sub End If If dtFrom2 <= 0 Or dtTo2 <= 0 Then bMultiRng = False Else bMultiRng = True ' If there is a comparison date range fed, then validate. If bMultiRng Then If dtFrom2 > dtTo2 Then MsgBox "Please ensure that the starting date of comparison range 2 comes prior or equal to the ending date." Exit Sub ElseIf (dtFrom2 >= dtFrom And dtFrom2 <= dtTo) Or (dtTo2 >= dtFrom And dtFrom2 <= dtTo) Then MsgBox "Please ensure that the two comparison dates are not overlapping before continuing." Exit Sub End If End If ' Determine how many pivot tables are related to the target for tracking original row field variables. ' Define the first dimension on the multidimensional tracking array. Hate looping twice, figure out a better way later! For Each WS In ActiveWorkbook.Worksheets For Each Pvt In WS.PivotTables If Pvt.CacheIndex = TargetPvtFld.Parent.CacheIndex Then ' Record the number of pivot tables. iPvtTblRowCnt = iPvtTblRowCnt + 1 i = 0 ' Loop through and determine the number of maximum fields. For Each PvtFld In Pvt.PivotFields If PvtFld.Orientation = xlRowField Then i = i + 1 If i > iPvtTblColCnt Then iPvtTblColCnt = i End If Next PvtFld End If Next Pvt Next WS ' Dimension full size of multidimensional array to store info about current state of linked pivot tables. ' The first field will contain each pivot tables name. The second field will contain the name of each pivot table field that ' is currently a row field for restoration after the event date filtering. ReDim sarrPvtInfo(0 To iPvtTblRowCnt, 0 To iPvtTblColCnt) ' Reset increment counters. i = 0 j = 0 ' Loop one more time through each pivot cache and record each related pivot table's name and it's respective ' pivot field names in the array for future use. For Each WS In ActiveWorkbook.Worksheets For Each Pvt In WS.PivotTables If Pvt.CacheIndex = TargetPvtFld.Parent.CacheIndex Then sarrPvtInfo(i, 0) = Pvt.Name j = 1 For Each PvtFld In Pvt.PivotFields If PvtFld.Parent.Name = TargetPvtFld.Parent.Name Then If PvtFld.Orientation = xlRowField Then sarrPvtInfo(i, j) = PvtFld.Name j = j + 1 ' Now remove the field after storing it. It will be returned after the date change. PvtFld.Orientation = xlHidden Else If PvtFld.Name <> "Values" Then End If End If End If ' Remove all column labels (except values) to ensure proper ungrouping. If PvtFld.Orientation = xlColumnField And PvtFld.Name <> "Values" Then PvtFld.Orientation = xlHidden End If Next PvtFld i = i + 1 End If Next Pvt Next WS ' In order to filter, there cannot be any filters on the data from the slicers. ' First identify the target pivot field's slicer caches. i = 0 iSlcRowCnt = 0 For Each SlcCache In ActiveWorkbook.SlicerCaches For Each Pvt In SlcCache.PivotTables If Pvt = TargetPvtFld.Parent And Not SlcCache.Name Like "*event_date*" Then Debug.Print " -----" & vbNewLine & SlcCache.Name & vbNewLine & " ----- " Debug.Print Pvt.Name If i > iSlcRowCnt Then iSlcRowCnt = i i = i + 1 End If Next Pvt Next SlcCache ' Size the array based off of our values. ReDim sarrSlcInfo(0 To iSlcRowCnt, 0 To 0) ' Reset the increment counters - again. i = 0 j = 0 ' Now loop through all the slicer caches and find which cache has slicers related to the pivot table. If ' those slicers have disabled items, record them and, after all are recorded, remove the filter to prevent ' issues during the date grouping process. For Each SlcCache In ActiveWorkbook.SlicerCaches For Each Pvt In SlcCache.PivotTables If Pvt = TargetPvtFld.Parent And Not SlcCache.Name Like "*event_date*" Then sarrSlcInfo(i, 0) = SlcCache.Name j = 1 For Each SlcItm In SlcCache.SlicerItems If Not SlcItm.Selected Then ReDim Preserve sarrSlcInfo(0 To UBound(sarrSlcInfo, 1), j) sarrSlcInfo(i, j) = SlcItm.Name j = j + 1 End If Next SlcItm SlcCache.ClearManualFilter i = i + 1 End If Next Pvt Next SlcCache ' Now begin to actually filter the dates. With TargetPvtFld .Orientation = xlRowField .ClearAllFilters ' This dynamically removes all grouped Event_Date fields prior to the grouping to come. ' This only needs to be performed on a single pivot, other related pivots will have the grouped ' fields removed as well via the cache. For Each PvtFld In .Parent.PivotFields If PvtFld.Name Like .Name & "?" Then PvtFld.Orientation = xlRowField PvtFld.Position = 1 PvtFld.ClearAllFilters iGrpTrack = iGrpTrack + 1 End If Next PvtFld i = 0 Do Until i >= iGrpTrack If iGrpTrack = 0 Then Exit Do .DataRange.Cells.Ungroup i = i + 1 Loop End With ' Now create the two groups as necessary with a third "Other" group to exclude. ' Comparison Group #1 *----- ' Loop through all cells in the date's data range and add all those that match the first criteria to a range for grouping. For Each xCell In TargetPvtFld.DataRange.Cells If xCell.Value >= dtFrom And xCell.Value <= dtTo Then 'If this is the first encountered occurrence of a match, add it. If rngGroup Is Nothing Then Set rngGroup = xCell Else ' Otherwise, union it with the existing range. Set rngGroup = Union(rngGroup, xCell) End If End If Next xCell ' Finally, group the range. By default the range will inherit the the name Group1. rngGroup.Group ' Comparison Group #2 *------ If bMultiRng Then Set rngGroup = Nothing For Each xCell In TargetPvtFld.DataRange.Cells If xCell.Value >= dtFrom2 And xCell.Value <= dtTo2 Then If rngGroup Is Nothing Then Set rngGroup = xCell Else Set rngGroup = Union(rngGroup, xCell) End If End If Next xCell rngGroup.Group End If ' Excluded events group *------ Set rngGroup = Nothing For Each xCell In TargetPvtFld.DataRange.Cells If bMultiRng Then If Not (xCell.Value >= dtFrom And xCell.Value <= dtTo) _ And Not (xCell.Value >= dtFrom2 And xCell.Value <= dtTo2) _ And Not xCell.Value Like "*-*" _ And Not xCell.Value Like "Group*" Then If rngGroup Is Nothing Then Set rngGroup = xCell Else Set rngGroup = Union(rngGroup, xCell) End If End If Else If Not (xCell.Value >= dtFrom And xCell.Value <= dtTo) _ And Not xCell.Value Like "*-*" _ And Not xCell.Value Like "Group*" Then If rngGroup Is Nothing Then Set rngGroup = xCell Else Set rngGroup = Union(rngGroup, xCell) End If End If End If Next xCell rngGroup.Group ' Now that the grouping is complete, remove the target pivot field from the rows. TargetPvtFld.Orientation = xlHidden ' Perform the final steps to restore the pivot tables. ' Loop through each pivot table and rename each grouped field. Doing this by targeting the group name in the field rather than searching ' a range prevents the need to move the pivot fields around currently. For Each WS In ActiveWorkbook.Worksheets For Each Pvt In WS.PivotTables If Pvt.CacheIndex = TargetPvtFld.Parent.CacheIndex Then Pvt.PivotFields(TargetPvtFld.Name & "2").PivotItems("Group1").Value = dtFrom & " - " & dtTo ' Optionally rename comparison group 2 in each pivot table. After which rename the remaining fields to group "Other." If bMultiRng Then Pvt.PivotFields(TargetPvtFld.Name & "2").PivotItems("Group2").Value = dtFrom2 & " - " & dtTo2 Pvt.PivotFields(TargetPvtFld.Name & "2").PivotItems("Group3").Value = "Other" Else Pvt.PivotFields(TargetPvtFld.Name & "2").PivotItems("Group2").Value = "Other" End If ' Now filter out the "Other" group of event dates so they don't appear. Pvt.PivotFields(TargetPvtFld.Name & "2").PivotItems("Other").Visible = False ' Now, its time to place the modified event date column as our headers and ensure proper sorting. With Pvt.PivotFields(TargetPvtFld.Name & "2") .Orientation = xlColumnField .Position = 1 .PivotItems(dtFrom & " - " & dtTo).Position = 1 End With End If Next Pvt Next WS ' Finally, we're ready to restore the original row fields back to each pivot table. ' Reset again. i = 0 j = 0 ' Restore the target pivot field's row field segments. For i = 0 To UBound(sarrPvtInfo, 1) If sarrPvtInfo(i, 0) = TargetPvtFld.Parent.Name Then For j = 1 To UBound(sarrPvtInfo, 2) If sarrPvtInfo(i, j) <> "" Then TargetPvtFld.Parent.PivotFields(sarrPvtInfo(i, j)).Orientation = xlRowField End If Next j End If Next i ' Now restore the target pivot field's slicer filters. ' First, disable updating on the pivot table until completed. TargetPvtFld.Parent.ManualUpdate = True For i = 0 To UBound(sarrSlcInfo, 1) For j = 1 To UBound(sarrSlcInfo, 2) If sarrSlcInfo(i, j) <> "" Then ActiveWorkbook.SlicerCaches(sarrSlcInfo(i, 0)).SlicerItems(sarrSlcInfo(i, j)).Selected = False End If Next j Next i ' Finally, we'll reset the print area. For Each WS In ActiveWorkbook.Worksheets For Each Pvt In WS.PivotTables If Pvt.CacheIndex = TargetPvtFld.Parent.CacheIndex Then With WS .PageSetup.PrintArea = "" LastRow = .Cells.Find(What:="*", searchorder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row LastCol = .Cells.Find(What:="% Sold", searchorder:=xlColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Address End With End If Next Pvt Next WS ' Once more reenable automatic updating. TargetPvtFld.Parent.ManualUpdate = False ' Reeanble application updating. With Application .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With 结束小组
我一直在困扰着我的大脑几天试图找出这个，所以任何帮助非常感谢！
我的问题：
我有一个数据透视表，有一个date报告filter声明，我循环给定一些单元格input，以dynamic过滤数据。 我有循环正确运行和过滤数据，但是它可以通过每个项目的可见性属性循环（从完整的项目列表到最小的子集最多3.5分钟）。 我正在寻找方法来优化这个广泛的网上看后（严重的是，我花了至less6个小时以上）。 它显然是数百万美元的Pivotitems.visible属性（每个项目多达一秒），我似乎无法想出一个方法来加速它。
我试过的东西：
在我的代码中（下面）我已经尝试/完成以下内容：
-
将应用程序设置设置为false
With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .CalculationMethod = xlManual End with -
设置数据透视表项上的手动更新字段。
With Pivottable("somepivottable").Pivotfields("thatonefield") .ManaulUpdate = True End with- 这实际上并不奏效，因为即使将应用程序设置设置为false，手动更新设置为true，我仍然可以清楚地看到应用程序在将项目设置为可见时暂停（大约.5到每个项目的整秒使其可见状态改变）
-
试图将filter设置为另一个数据透视表上的列（通过同一caching中的切片器连接）并设置标签filter。 没有想到这会工作..它没有。
-
试图macroslogging实际的filterselect过程（这几乎是瞬间的）。 从我得到的，我试图显式声明每个数据透视表项为true或false，但是这与我的标准代码具有相同的周转时间。
那就是我所在的地方 我没有其他的想法。 我的数据透视表实际上是从一个SAS数据集（平面文件，而不是OLAP立方体）创build的，所以数据不是物理上的工作簿，这是我喜欢的，因为数据接近800k行，并将继续增长，可能会增加一倍。 由于SAS插件将数据直接拖到数据透视caching，我可以避免数据限制。
我的代码如此之远：
这仍然是相当粗糙的，因为我仍然在整理一些优点，尽pipe我也可以开放其他优化。 代码是从一个用户窗体调用的，并且是我从这里find并修改为接受两个连续date范围的代码的修改副本。
Public Function Filter_PivotField_by_Date_Range(pvtField As PivotField, _ dtFrom As Date, dtTo As Date, Optional ByVal dtFrom2 As Date, Optional ByVal dtTo2 As Date) ' Got the original (very useful) function from: ' http://www.mrexcel.com/forum/excel-questions/669688-select-date-range-pivot-table-using-visual-basic-applications.html ' Modified to use two non-continguous date ranges for YoY analysis. ' Ex: 1/1/2014 - 1/30/2014 AND 1/2/2013 - 2/1/2013 ' Variables ----- Dim blSingleRange As Boolean, blFormLoaded As Boolean Dim bTemp As Boolean, bTemp2 As Boolean, i As Long, iFirst As Long Dim dtTemp As Date, sItem1 As String Dim PT As PivotTable Dim Sheet As Worksheet ' --------------- On Error Resume Next If dtFrom2 <= 0 Or dtTo2 <= 0 Then blSingleRange = True End If With pvtField For i = 1 To .PivotItems.Count dtTemp = .PivotItems(i) bTemp = (dtTemp >= dtFrom) And (dtTemp <= dtTo) If Not blSingleRange Then bTemp2 = (dtTemp >= dtFrom2) And (dtTemp <= dtTo2) End If If bTemp Or bTemp2 Then sItem1 = .PivotItems(i) Exit For End If Next i If sItem1 = "" Then MsgBox "No items are within the specified dates." Exit Function End If Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual For Each Sheet In ActiveWorkbook.Sheets For Each PT In Sheet.PivotTables If PT.CacheIndex = .Parent.CacheIndex Then PT.ManualUpdate = True End If Next PT Next Sheet If .Orientation = xlPageField Then .EnableMultiplePageItems = True blFormLoaded = UserformFunctions.IsUserFormLoaded("DateProgressForm") For i = 1 To .PivotItems.Count dtTemp = .PivotItems(i) If blSingleRange Then If .PivotItems(i).Visible <> ((dtTemp >= dtFrom) And (dtTemp <= dtTo)) Then .PivotItems(i).Visible = Not .PivotItems(i).Visible End If Else If (((dtTemp >= dtFrom) And (dtTemp <= dtTo)) _ Or ((dtTemp >= dtFrom2) And (dtTemp <= dtTo2))) Then If .PivotItems(i).Visible = False Then .PivotItems(i).Visible = True Else If .PivotItems(i).Visible = True Then .PivotItems(i).Visible = False End If End If ' Update the progress userform. siPrctComp = Round((i / .PivotItems.Count) * 100, 2) If blFormLoaded Then UserformFunctions.Form_Progress (siPrctComp) DoEvents End If Next i ' Reset the manual update property of each connected pivot table. For Each Sheet In ActiveWorkbook.Sheets For Each PT In Sheet.PivotTables If PT.CacheIndex = .Parent.CacheIndex And PT.ManualUpdate = True Then PT.ManualUpdate = False End If Next PT Next Sheet End With Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Function
我还没有注意到更新进度的用户窗体（只是一个进度条，因为它需要这么长时间，让用户知道它的实际工作）。 如果我可以通过删除它来更快地完成工作，那么即使是在DoEvents调用之后，我也会尽快完成。 我也尝试将工作簿中的所有数据透视表设置为manualupdate = true，只是当前的一个，没有改变。
我注意到的一件事是，当代码中断（或者我插入一个断点/步骤）时，manualupdate属性重新设置为false。 我不确定这是否是由devise，或者如果我的工作簿/数据透视表有什么特别的错误。
我也试图find一种方法来使用一个数组来批量应用可见的属性，但似乎不可能。
感谢您能够提供的任何帮助，非常感谢您的帮助，如果您需要我的帮助，请告诉我。
编辑回答一些评论（谢谢你回复大家！）
- 首先，我忘记提到这一点，但我使用Excel 2010 32位道歉。
这里是macroslogging报告filter或切片机更改时得到的代码的示例。 这几乎立即通过Excel的惯例手动方法，但没有太多，如果通过VBA模拟（即使速度提高）。 如果这可以工作，我会编写代码来提取事件date范围，并在每次更新数据时重写自定义macros。
Sub Macro1() ' ' Macro1 Macro ' ActiveSheet.PivotTables("SASApp:CORPTICK.HISTORICAL_SALES").PivotFields( _ "event_date").CurrentPage = "(All)" With ActiveSheet.PivotTables("SASApp:CORPTICK.HISTORICAL_SALES").PivotFields( _ "event_date") .PivotItems("07/01/2014").Visible = True .PivotItems("07/02/2014").Visible = True .PivotItems("07/04/2013").Visible = True .PivotItems("07/05/2013").Visible = True End With ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.0").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.1").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.2").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.3").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.4").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.5").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.6").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702").Delete ActiveWorkbook.Names.Add Name:="_AMO_ContentDefinition_105016702.0", _ RefersToR1C1:= _ "=""'<ContentDefinition name=""""SASApp:CORPTICK.HISTORICAL_SALES"""" rsid=""""105016702"""" type=""""PivotTable"""" format=""""ReportXml"""" imgfmt=""""ActiveX"""" created=""""07/01/2014 11:56:37"""" modifed=""""07/16/2014 15:31:46"""" user=""""xxx"""" apply=""""False"""" css='""" ' And if I adjust a slicer - I've removed a lot of the code for the sake of length but it was mostly just all .Selected=False for all the non-selected code. With ActiveWorkbook.SlicerCaches("Slicer_event_date") .SlicerItems("07/03/2013").Selected = True .SlicerItems("07/04/2013").Selected = True .SlicerItems("07/05/2013").Selected = True .SlicerItems("07/06/2013").Selected = True End With ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.0").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.1").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.2").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.3").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.4").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.5").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702.6").Delete ActiveWorkbook.Names("_AMO_ContentDefinition_105016702").Delete ActiveWorkbook.Names.Add Name:="_AMO_ContentDefinition_105016702.0", _ RefersToR1C1:= _ "=""'<ContentDefinition name=""""SASApp:CORPTICK.HISTORICAL_SALES"""" rsid=""""105016702"""" type=""""PivotTable"""" format=""""ReportXml"""" imgfmt=""""ActiveX"""" created=""""07/01/2014 11:56:37"""" modifed=""""07/16/2014 15:31:46"""" user=""""xxx"""" apply=""""False"""" css='""" End Sub
另一种方法是按date范围对Rowfield项目进行分组，然后按这些组进行筛选。
当字段是数据透视表的“报表filter”区域时，您无法对项目进行分组; 但是您可以临时将该字段移至行标签区域>按date分组>将字段移至报告filter区域，然后隐藏超出您所需date范围的组项目。
对于单个“date之间”filter，这不是太复杂。 像这样的“A10”是你的领域的第一个PivotItem（实际的代码将需要find该单元格）…
Public Function Filter_PivotField_by_Date_Range(pvtField As PivotField, _ dtFrom As Date, dtTo As Date, Optional ByVal dtFrom2 As Date, Optional ByVal dtTo2 As Date) With pvtField '--make a rowfield if not already If .Orientation <> xlRowField Then .Orientation = xlRowField .ClearAllFilters '--add code to find a pivotitem Range("A10").Group Start:=CLng(dtFrom), End:=CLng(dtTo), _ Periods:=Array(False, False, _ False, False, False, False, True) '--move to report filters area .Orientation = xlPageField .Position = 1 End With End Function
对于两个“date间”范围，仍然可以完成，但是您可能需要使所有项目可见>按datesorting>然后使用“匹配”或“查找”来查找每个date范围的开始和结束以进行组。
你有没有考虑过，你只是碰到了处理数据透视表的EXCEL（在今天的硬件上）的限制：
And that's where I'm at. I have no other ideas. My pivot table is actually created from a SAS dataset (flat file, not OLAP cube) so the data isn't physically in the workbook which is what I prefer since the data is nearing 800k rows and will continue to grow to possibly double the size. Since the SAS addin pulls the data directly into the pivot cache I can avoid data restraints
你正在谈论800K行的数据，可能很快就翻倍到1600K行，而EXCEL最近才破解了65K的限制。
如何修改您的SAS数据集查询只返回指定date范围内的logging？
如果您使用的是Excel 2007或更高版本，则可以将数据PivotFilter添加到数据PivotField并使用xlDateBetweentypes在date范围内进行筛选（这将覆盖大小写blSingleRange = True ：
pvtField.PivotFilters.Add Type:=xlDateBetween, Value1:=CLng(dtFrom), Value2:=CLng(dtTo)