Filter Pivot Table Between Dates Using Cell Values

Question

I have a pivot table which lists a count of how many inventory items were sold between a date range. The to and from dates are stored in cells so the user may modify them.

I've written code that references these cells and attempts to filter the pivot table on the sheet.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address = ActiveSheet.Range("E3").Address Then
        ActiveSheet.PivotTables("ItemsSold").RefreshTable
    ElseIf Target.Address = ActiveSheet.Range("I3").Address Then
        ActiveSheet.PivotTables("ItemsSold").RefreshTable
    End If

    ActiveSheet.PivotTables("ItemsSold").PivotFields("Date Sold ").PivotFilters.Add _
        Type:=xlDateBetween, _
        Value1:=CLng(Range("E3").value), _
        Value2:=CLng(Range("I3").value)

End Sub

I get

"Run Time Error 1004:Application-defined or object-defined error".

Refreshing the table is working properly, but filtering it is not.

An additional complication: will this work if one of the dates (say, Date From:) does not exist on the table? For example, if I want to filter between January 1st and today, but there are no January dates in the data table, will this code still execute properly?

Answer 1

Date Sold field could be located in Row or Column Labels area, or Report Filter area, as shown on the screenshots:

Row Labels area

Report Filter area

The following code should be pasted in worksheet module, and it consists of two sub-parts, the first for work with field located in Report Filter area, and the second for Row or Column Labels area:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rFrom As Range
    Dim rUpto As Range
    Dim lFrom As Long
    Dim lUpto As Long
    Dim oPivotField As PivotField
    Dim oPivotItem As PivotItem
    Dim sFmt As String
    Dim bItemVisible As Boolean
    Dim cPivotFilters As PivotFilters
    Dim oFilter As PivotFilter

    Set rFrom = ActiveSheet.Range("E3")
    Set rUpto = ActiveSheet.Range("I3")
    If Target.Address = rFrom.Address Or Target.Address = rUpto.Address Then
        Set oPivotField = ActiveSheet.PivotTables("ItemsSold").PivotFields("Date Sold")
        Select Case oPivotField.Orientation
            ' Check if field located in Report Filter area
            Case xlPageField
                ' Prepare for update
                Application.EnableEvents = False
                Application.ScreenUpdating = False
                On Error Resume Next ' to be sure the initial state is restored
                ' Remove existing filters for pivot field
                oPivotField.EnableMultiplePageItems = True
                oPivotField.ClearAllFilters
                ' Store current field format
                sFmt = oPivotField.NumberFormat
                ' Change format to compare Long type values and avoid date formats regional mess
                oPivotField.NumberFormat = "0"
                If IsDate(rFrom) Then
                    lFrom = CLng(rFrom)
                Else
                    lFrom = 0
                End If
                If IsDate(rUpto) Then
                    lUpto = CLng(rUpto)
                Else
                    lUpto = 2958465
                End If
                ' Loop through each page field item and check if at least one item is visible
                For Each oPivotItem In oPivotField.PivotItems
                    bItemVisible = oPivotItem.Value >= lFrom And oPivotItem.Value <= lUpto
                    If bItemVisible Then Exit For
                Next
                If bItemVisible Then
                    ' Loop through each page field item and switch visibility
                    For Each oPivotItem In oPivotField.PivotItems
                        oPivotItem.Visible = oPivotItem.Value >= lFrom And oPivotItem.Value <= lUpto
                    Next
                Else
                    MsgBox "There is no data to show for range you set", vbInformation
                End If
                ' Restore initial state
                oPivotField.NumberFormat = sFmt
                Application.EnableEvents = True
                Application.ScreenUpdating = True
                On Error GoTo 0
                ActiveSheet.PivotTables("ItemsSold").RefreshTable
            ' Check if field located in Row or Column Labels area
            Case xlColumnField, xlRowField
                Set cPivotFilters = oPivotField.PivotFilters
                ' Prepare for update
                Application.EnableEvents = False
                Application.ScreenUpdating = False
                On Error Resume Next ' to be sure the initial state is restored
                ' Remove existing date filters for pivot field
                Set cPivotFilters = ActiveSheet.PivotTables("ItemsSold").PivotFields("Date Sold").PivotFilters
                For Each oFilter In cPivotFilters
                    If _
                        oFilter.FilterType = xlDateBetween Or _
                        oFilter.FilterType = xlBefore Or _
                        oFilter.FilterType = xlAfter Then _
                            oFilter.Delete
                Next
                ' Add new filter regarding of set range
                Select Case True
                    Case IsDate(rFrom) And IsDate(rUpto)
                        cPivotFilters.Add Type:=xlDateBetween, Value1:=CDbl(rFrom), Value2:=CDbl(rUpto)
                    Case IsDate(rFrom)
                        cPivotFilters.Add Type:=xlAfter, Value1:=CDbl(rFrom)
                    Case IsDate(rUpto)
                        cPivotFilters.Add Type:=xlBefore, Value1:=CDbl(rUpto)
                End Select
                ' Restore initial state
                Application.EnableEvents = True
                Application.ScreenUpdating = True
                On Error GoTo 0
                ActiveSheet.PivotTables("ItemsSold").RefreshTable

            Case Else
                MsgBox "The field should be located in Row or Column Labels area, or Report Filter area", vbInformation
            End Select
    End If

End Sub