excel - VBA，应用程序定义或对象错误，更改透视筛选器

Question

我正在尝试使用基于单元格的 vba 更改枢轴过滤器。
我收到错误 Application-defined or Object Error在我的第二行代码上。

Sub RefreshPivots()

Sheets("Details").PivotTables("PivotTable1").PivotCache.Refresh
Sheets("Details").PivotTables("PivotTable2").PivotCache.Refresh


temp = Sheets("Input").Range("H2")
Sheets("Details").PivotTables("PivotTable1").PivotFields("Period").PivotFilters.Add Type:=xlCaptionEquals, Value1:=temp

  

End Sub

我正在尝试切换到我在 Sheets("Input").Range("H2") 中的日期因此，如果我在这个单元格中有 9 月 10/20 日，我希望枢轴更新到那个。


有谁知道我做错了什么？
谢谢。
枢轴字段:

透视源数据，也许这种格式可能是为什么？

filterDate 值基于基督徒代码:

Answer 1

首先我认为Period字段必须位于“数据透视表字段” Pane 的“行”部分下(单独或在其他字段中 - 顺序无关紧要):

然后你需要替换这个:

temp = Sheets("Input").Range("H2")
Sheets("Details").PivotTables("PivotTable1").PivotFields("Period").PivotFilters.Add Type:=xlCaptionEquals, Value1:=temp

有了这个:

With Sheets("Details").PivotTables("PivotTable1").PivotFields("Period")
    .ClearAllFilters
    .PivotFilters.Add Type:=xlSpecificDate, Value1:=Sheets("Input").Range("H2").Value2
End With

您可能需要在运行代码之前进行一些检查，因为工作表名称以及数据透视表名称等可能会发生变化。也代替 Sheets也许使用 ThisWorkbook.Worksheets .这样，您不会引用 ActiveWorkbook，而是引用运行代码的工作簿。
编辑
这是执行上述检查的代码:

Option Explicit

Sub RefreshPivots()
    Dim pivTable1 As PivotTable
    Dim pivTable2 As PivotTable
    
    Set pivTable1 = GetPivotTable(ThisWorkbook, "Details", "PivotTable1")
    If pivTable1 Is Nothing Then
        'Do Something. Maybe Exit or display a MsgBox
    End If
    pivTable1.PivotCache.Refresh
    
    Set pivTable2 = GetPivotTable(ThisWorkbook, "Details", "PivotTable2")
    If pivTable2 Is Nothing Then
        'Do Something. Maybe Exit or display a MsgBox
    End If
    pivTable2.PivotCache.Refresh
    
    Dim periodField As PivotField
    
    On Error Resume Next
    Set periodField = pivTable1.PivotFields("Period")
    On Error GoTo 0
    If periodField Is Nothing Then
        'Do Something. Maybe Exit or display a MsgBox
    End If
    On Error GoTo 0
    
    Dim filterDate As Variant
    
    On Error Resume Next
    filterDate = ThisWorkbook.Worksheets("Inputs").Range("H2").Value2
    If Err.Number <> 0 Then
        'Do Something. Maybe Exit or display a MsgBox
    Else
        Select Case VarType(filterDate)
        Case vbDouble
            'Maybe check if serial number is valid
        Case vbString
            filterDate = CDbl(CDate(filterDate))
        Case Else
            'Maybe show a MsgBox
            Exit Sub
        End Select
    End If
    On Error GoTo 0
    
    With periodField
        .ClearAllFilters
        .PivotFilters.Add Type:=xlSpecificDate, Value1:=filterDate
    End With
End Sub

Private Function GetPivotTable(ByVal sourceBook As Workbook _
    , ByVal wSheetName As String _
    , ByVal pivotName As String _
) As PivotTable
    On Error Resume Next
    Set GetPivotTable = sourceBook.Worksheets(wSheetName).PivotTables(pivotName)
    On Error GoTo 0
End Function

编辑 2
我简化了过滤日期检查并添加了一些代码而不是“也许”注释:

Sub RefreshPivots()
    Dim pivTable1 As PivotTable
    Dim pivTable2 As PivotTable
    
    Set pivTable1 = GetPivotTable(ThisWorkbook, "Details", "PivotTable1")
    If pivTable1 Is Nothing Then
        MsgBox "Missing Pivot Table", vbInformation, "Cancelled"
        Exit Sub
    End If
    pivTable1.PivotCache.Refresh
    
    Set pivTable2 = GetPivotTable(ThisWorkbook, "Details", "PivotTable2")
    If pivTable2 Is Nothing Then
        MsgBox "Missing Pivot Table", vbInformation, "Cancelled"
        Exit Sub
    End If
    pivTable2.PivotCache.Refresh
    
    Dim periodField As PivotField
    
    On Error Resume Next
    Set periodField = pivTable1.PivotFields("Period")
    On Error GoTo 0
    If periodField Is Nothing Then
        MsgBox "Missing Pivot Field", vbInformation, "Cancelled"
        Exit Sub
    End If
    On Error GoTo 0
    
    'Maybe check if date is within a certain range
'    If filterDate < minDate Or filterDate > maxDate Then
'        MsgBox "Invalid Date", vbInformation, "Cancelled"
'        Exit Sub
'    End If

    Dim filterDate As Variant
    
    On Error Resume Next
    filterDate = ThisWorkbook.Worksheets("Inputs").Range("H2").Value2
    If VarType(filterDate) = vbString Then filterDate = CDbl(CDate(filterDate))
    If Err.Number <> 0 Or VarType(filterDate) <> vbDouble Then
        MsgBox "Missing/Invalid Filter Date", vbInformation, "Cancelled"
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    
    With periodField
        .ClearAllFilters
        .PivotFilters.Add Type:=xlSpecificDate, Value1:=filterDate
    End With
End Sub

编辑 3
基于更新的问题:

Option Explicit

Sub RefreshPivots()
    Dim pivTable1 As PivotTable
    Dim pivTable2 As PivotTable
    
    Set pivTable1 = GetPivotTable(ThisWorkbook, "Details", "PivotTable1")
    If pivTable1 Is Nothing Then
        MsgBox "Missing Pivot Table", vbInformation, "Cancelled"
        Exit Sub
    End If
    pivTable1.PivotCache.Refresh
    
    Set pivTable2 = GetPivotTable(ThisWorkbook, "Details", "PivotTable2")
    If pivTable2 Is Nothing Then
        MsgBox "Missing Pivot Table", vbInformation, "Cancelled"
        Exit Sub
    End If
    pivTable2.PivotCache.Refresh
    
    Dim periodField As PivotField
    
    On Error Resume Next
    Set periodField = pivTable1.PivotFields("Period")
    On Error GoTo 0
    If periodField Is Nothing Then
        MsgBox "Missing Pivot Field", vbInformation, "Cancelled"
        Exit Sub
    End If
    periodField.ClearAllFilters
    
    'Maybe check if date is within a certain range
'    If filterDate < minDate Or filterDate > maxDate Then
'        MsgBox "Invalid Date", vbInformation, "Cancelled"
'        Exit Sub
'    End If

    Dim filterDate As Variant
    
    On Error Resume Next
    filterDate = ThisWorkbook.Worksheets("Inputs").Range("H2").Value2
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "Missing Filter Date", vbInformation, "Cancelled"
        Exit Sub
    End If
    
    'Try String first
    If VarType(filterDate) = vbString Then
        periodField.PivotFilters.Add Type:=xlCaptionEquals, Value1:=filterDate
        If Err.Number = 0 Then Exit Sub
        
        filterDate = CDbl(CDate(filterDate))
        Err.Clear
    End If
    
    If VarType(filterDate) <> vbDouble Then
        MsgBox "Invalid Filter Date", vbInformation, "Cancelled"
        Exit Sub
    End If
    
    'Try Date (as Double data type)
    periodField.PivotFilters.Add Type:=xlSpecificDate, Value1:=filterDate
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "Could not apply filter", vbInformation, "Cancelled"
        Exit Sub
    End If
End Sub

Private Function GetPivotTable(ByVal sourceBook As Workbook _
    , ByVal wSheetName As String _
    , ByVal pivotName As String _
) As PivotTable
    On Error Resume Next
    Set GetPivotTable = sourceBook.Worksheets(wSheetName).PivotTables(pivotName)
    On Error GoTo 0
End Function