自动过滤器在PIVOT TABLE中持续13个月

Question

我有两个切片＆＃34;月＆＃34;和＆＃34;年＆＃34;，我需要一个VBA代码来自动过滤选择器中的PT，例如，用户选择月 - 三月和2017年，过滤器应该应用月 - 四月到三月和一年 - 2016 ＆安培; 2017。

Sub Period_Last_12_Months()

Dim pi As PivotItem, Cutoffmonth As String, CuttoffYear As String
Dim sMonthName As String
Dim Calc As String

sMonthName = ThisWorkbook.Sheets("margin pool").Range("B1").Value
Cutoffmonth = Format(DateAdd("m", -13, CDate(sMonthName & "/1/2000")), "mmmm")
cutoffyear = ThisWorkbook.Sheets("margin pool").Range("B2").Value
''  Calc = Cutoffmonth & " " & cutoffyear
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("margin pool").PivotTables("PivotTable2")
    .ManualUpdate = True
    With .PivotFields("Month")
        For Each pi In .PivotItems
            pi.Visible = (Format(CDate(pi & "/1/2000"), "mmmm")) > Cutoffmonth
        Next pi
        End With
        With .PivotFields("Year")
        For Each pi In .PivotItems
        pi.Visible = DateValue(pi.Year) > cutoffyear
        Next pi
        End With
    .ManualUpdate = False

        End With
Application.ScreenUpdating = True

End Sub      

截图

Answer 1

以下代码将在“数据输入”工作表中的整个数据的“AR”列中添加Date格式。

然后在“margin pool”工作表中创建/更新“PivotTable2”。

最后，它将仅显示单元格“B2”中所选日期的390d（~13个月）内的记录。

完整代码

Option Explicit

Sub Period_Last_12_Months()

Dim PvtTbl      As PivotTable
Dim PvtCache    As PivotCache
Dim PvtItm      As PivotItem
Dim PvtDataRng  As Range

Dim Cutoffmonth As String, CuttoffYear As String
Dim sMonthName As String
Dim Calc As String

Dim LastRow As Long, i As Long

' === first sort the data for the Pivot Table ===
With Worksheets("Data Input")
    LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row ' get last row with data in column "O"

    .Range("AR2:AR" & LastRow).Formula = "=DATEVALUE(CONCATENATE(" & Chr(34) & "1/" & Chr(34) & ",N2," & Chr(34) & "/" & Chr(34) & ",O2))"
    .Range("AR2:AR" & LastRow).NumberFormat = "m/d/yyyy"

    Set PvtDataRng = .Range("A1:AR" & LastRow) ' <-- set the Range for the Pivot Table
End With

' === set the Pivot Table ===
Set PvtCache = ActiveWorkbook.PivotCaches.Add(xlDatabase, PvtDataRng)

' Set the Pivot Table (already created in previous macro run)
On Error Resume Next
Set PvtTbl = ThisWorkbook.Sheets("margin pool").PivotTables("PivotTable2")

On Error GoTo 0
If PvtTbl Is Nothing Then ' <-- pivot table still doesn't exist >> need to create it

    ' create a new Pivot Table in ws2 sheet, start from Cell A5
    Set PvtTbl = ThisWorkbook.Sheets("margin pool").PivotTables.Add(PivotCache:=PvtCache, TableDestination:=ThisWorkbook.Sheets("margin pool").Range("A5"), TableName:="PivotTable2")

    With PvtTbl.PivotFields("MyDate") ' add MyDate as Pivot Table's filter
        .Orientation = xlPageField
        .Position = 1
    End With
Else
    ' just refresh the Pivot table, with updated Pivot Cache
    PvtTbl.ChangePivotCache PvtCache
    PvtTbl.RefreshTable
End If


Dim toDate As Date

toDate = ThisWorkbook.Sheets("margin pool").Range("B2").Value ' <-- get the date value from Cell B2

Application.ScreenUpdating = False

With PvtTbl
    .ManualUpdate = True
    With .PivotFields("MyDate") ' <-- depends on the column's header of the new column we added (I have in "AR1" Mydate as Text)
        .ClearAllFilters
        For Each PvtItm In .PivotItems
            PvtItm.Visible = DateDiff("d", CDate(PvtItm.Name), toDate) < 13 * 30 ' <-- less than 13 months (took 30 days in a month)
        Next PvtItm
    End With
    .ManualUpdate = False
End With

Application.ScreenUpdating = True

End Sub

数据透视表字段屏幕截图：

运行此代码屏幕截图后的数据透视表结果：

• 单元格中的值“B2为01-01-2017（日期格式）
• 当天390天内的所有项目均为可见