首先，我为此道歉很长时间。写完这篇文章后不久，我就出城了，然后离开了这个项目，直到我最近能够找到工作时间。
杰瑞给了我在行标签上使用群组的好主意，而不是试图一次过滤一个日期。通过一些修改，我能够以更快的速度满足我的需求。在最慢的时候，我将时间从最多5分钟缩短到45分钟，并且随着时间的推移我仍然会做出优化。这是一种很好的方法，可以让我更新几个相关的数据透视表。那些可能会发现它有用的代码 - 请注意它包括很多额外内容：
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
End Sub
几天来我一直在挣扎着想要解决这个问题，所以非常感谢任何帮助！
我有一个数据透视表，其中声明了一个日期报告过滤器，我通过给定一些单元格输入来循环，以便动态过滤数据。我有正确的循环运行并过滤数据，但是它可以花费大量时间来遍历每个项目的可见属性（从完整项目列表到较小的子集时最多3.5分钟）。我正在寻找在网上广泛观看之后优化这一点的方法（严肃地说，我花了至少6个多小时的时间）。很明显，Pivotitems.visible属性需要很长时间（每件项目可达一秒），我似乎无法找到加快速度的方法。
在我的代码（下方）中，我尝试过/完成以下操作：
将应用程序设置设为false
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.CalculationMethod = xlManual
End with
在数据透视表项目上设置手动更新字段。
With Pivottable("somepivottable").Pivotfields("thatonefield")
.ManaulUpdate = True
End with
尝试将过滤器设置为另一个数据透视表上的列（通过同一缓存中的切片器连接）并设置标签过滤器。不认为这会起作用..它没有。
尝试宏记录枢轴上的实际过滤器选择过程（几乎是瞬时的）。从我得到的，我试图明确地声明每个枢轴项目为真或假，但这与我的标准代码具有相同的周转时间。
这就是我所处的位置。我没有其他想法。我的数据透视表实际上是从SAS数据集（平面文件，而不是OLAP多维数据集）创建的，因此数据实际上不在工作簿中，这是我喜欢的，因为数据接近800k行并且将继续增长到可能加倍的大小。由于SAS插件将数据直接拉入数据透视缓存，因此可以避免数据限制。
这仍然非常粗糙，因为我仍在整理一些优点，尽管我对其他优化也很开放。代码是从用户表单调用的，是我从here找到并修改为接受两个连续日期范围的代码的修改副本。
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。我不确定这是设计还是我的工作簿/数据透视表有什么特别的错误。
我还试图找到一种方法来使用数组批量应用可见属性，但似乎不可能。
以下是宏录制报表过滤器或切片器更改时获得的代码示例。这几乎可以通过Excel的惯例，手动方法立即工作，但如果通过VBA模仿（即使速度提高）也没有那么多。如果这样可行，我会编写代码来拉取事件日期范围，并在每次更新数据时重写自定义宏。
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
答案 0 :(得分：2)
您是否认为您只是遇到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行的数据，可能很快就会翻倍到1,600K行，而EXCEL最近才破解了65K的限制。
答案 1 :(得分：1)
如何将SAS数据集的查询修改为仅返回指定日期范围内的记录？
答案 2 :(得分：1)
如果您使用的是Excel 2007或更高版本，则可以向PivotFilter添加PivotField并使用xlDateBetween类型在您的日期范围内进行过滤（这将涵盖案例{{ 1}}：
blSingleRange = True答案 3 :(得分：1)
另一种方法是按日期范围对Rowfield项目进行分组，然后按这些组进行过滤。
当字段是数据透视表的“报表过滤器”区域时，您无法对项目进行分组;但是，您可以暂时将该字段移动到行标签区域＆gt;按日期分组＆gt;将该字段移动到“报告过滤器”区域，然后隐藏超出所需日期范围的“组”项。
对于单个＆＃34;日期和＃34;过滤这不太复杂。像这样的东西＆＃34; A10＆＃34;是你的领域的第一个PivotItem（实际代码需要找到那个单元格）......
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
日期之间的两个＆＃34;＆＃34;范围仍然可以完成，但您可能需要使所有项目可见＆gt;按日期排序＆gt;然后使用“匹配”或“查找”查找每个日期范围的开头和结尾以创建组。