基于VBA的OLAP数据透视表批量筛选问题求助

我正在编写可同时适配普通透视表与OLAP透视表的VBA批量筛选代码，目前在OLAP场景下遇到了严重问题。普通透视表中，调用pf.ClearAllFilters并遍历pf.PivotItems设置显示/隐藏的逻辑运行正常，但在OLAP透视表中触发以下错误：

• 错误438：“对象不支持该属性或方法”
• 设置pf.VisibleItemsList时触发错误5：“无效的过程调用或参数”
• 调用pf.CubeField属性时持续出现编译错误：“未找到方法或数据成员”

恳请帮忙解答如何在OLAP透视表的Filters、Rows、Columns区域字段上应用多选项筛选，也欢迎提供关于VisibleItemsList、HiddenItemsList及SlicerCache替代方案的相关建议。

用户窗体代码 #

Public Function NormalizarTexto(ByVal texto As Variant) As String
    Dim acentos As String, semAcentos As String, i As Long
    acentos = "áàãâäéèêëíìîïóòõôöúùûüçÁÀÃÂÄÉÈÊËÍÌÎÏÓÒÕÔÖÚÙÛÜÇ"
    semAcentos = "aaaaaeeeeiiiiooooouuuucAAAAAEEEEIIIIOOOOOUUUUC"

    texto = CStr(texto)

    texto = Replace(texto, Chr(160), " ")
    texto = Replace(texto, ChrW(8239), " ")
    texto = Replace(texto, ChrW(8194), " ")

    texto = Replace(texto, vbTab, "")
    texto = Replace(texto, vbCr, "")
    texto = Replace(texto, vbLf, "")

    texto = Trim(texto)

    For i = 1 To Len(acentos)
        texto = Replace(texto, Mid(acentos, i, 1), Mid(semAcentos, i, 1))
    Next i

    NormalizarTexto = texto
End Function

Private Sub btnLimpar_Click()
    Dim pt As PivotTable
    Dim pf As PivotField

    On Error GoTo TrataErro

    Set pt = ActiveCell.PivotTable
    If pt Is Nothing Then
        MsgBox "Nenhuma Tabela Dinâmica foi detectada. Selecione uma célula dentro de uma.", vbExclamation
        Exit Sub
    End If

    If cmbCampos.ListIndex = -1 Then
        MsgBox "Por favor, selecione um campo para limpar o filtro.", vbExclamation
        Exit Sub
    End If

    Set pf = pt.PivotFields(cmbCampos.Value)
    pf.ClearAllFilters

    MsgBox "Filtro limpo com sucesso para o campo: " & pf.Name, vbInformation
    Exit Sub

TrataErro:
    MsgBox "Erro ao limpar o filtro: " & Err.Description, vbCritical
End Sub

Private Sub UserForm_Initialize()
    Dim pt As PivotTable
    Dim pf As PivotField

    On Error Resume Next
    Set pt = ActiveCell.PivotTable
    On Error GoTo 0

    If pt Is Nothing Then
        MsgBox "Selecione uma célula dentro de uma Tabela Dinâmica antes de abrir o painel.", vbExclamation
        Unload Me
        Exit Sub
    End If

    For Each pf In pt.PivotFields
        If pf.Orientation <> xlDataField Then
            cmbCampos.AddItem pf.Name
        End If
    Next pf
End Sub

Private Sub UserForm_Activate()
    Dim ctrl As Control
    Dim maxBottom As Long
    Const MARGEM As Long = 40

    For Each ctrl In Me.Controls
        If ctrl.Visible = True Then
            If ctrl.Top + ctrl.Height > maxBottom Then
                maxBottom = ctrl.Top + ctrl.Height
            End If
        End If
    Next ctrl

    Me.Height = maxBottom + MARGEM
    
    DoEvents
    Me.Repaint
End Sub
Private Sub btnAplicar_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ' Cor quando o botão é pressionado
    btnAplicar.BackColor = RGB(0, 90, 180)
End Sub

Private Sub btnAplicar_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ' Cor ao soltar o botão (volta ao normal)
    btnAplicar.BackColor = RGB(0, 120, 215) ' cor original
End Sub

Public Sub MostrarPainelFiltro()
    With Me
        .BorderStyle = 0
        .StartUpPosition = 0
        .Top = 0
        .Left = Application.UsableWidth - .Width - 10
        .Height = Application.UsableHeight - 10
    End With
    Me.Show vbModeless
End Sub

Private Sub btnAplicar_Click()
    Dim pt As PivotTable
    Dim pf As PivotField
    Dim entradaTexto As String
    Dim linhas As Variant
    Dim valor As Variant
    Dim i As Long
    Dim dict As Object
    Dim listaNaoEncontrados As String
    Dim listaEncontrados As Object
    Dim achou As Boolean
    Dim nomeItem As Variant
    Dim chaveValor As Variant
    Dim compararA As String, compararB As String
    Dim modoFlexivel As Boolean
    Dim alerta As String
    Dim todosVisiveis As Object

    Set pt = ActiveCell.PivotTable
    On Error Resume Next
Set pf = pt.PivotFields(cmbCampos.Value)
On Error GoTo 0

If pf Is Nothing Then
    MsgBox "O campo '" & cmbCampos.Value & "' não foi encontrado na Tabela Dinâmica." & vbCrLf & _
           "Verifique se ele ainda está visível ou se você selecionou corretamente no painel.", vbCritical
    Exit Sub
End If
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set listaEncontrados = CreateObject("Scripting.Dictionary")
    Set todosVisiveis = CreateObject("Scripting.Dictionary")
    modoFlexivel = chkIgnorarAcentos.Value

    entradaTexto = IIf(IsNull(txtLista.Text), "", txtLista.Text)
    If Len(Trim(entradaTexto)) = 0 Then
        MsgBox "Nenhum valor foi colado. Por favor, cole sua lista antes de aplicar o filtro.", vbExclamation
        Exit Sub
    End If

    Set pt = ActiveCell.PivotTable
    If pt Is Nothing Then
        MsgBox "Nenhuma Tabela Dinâmica foi detectada. Selecione uma célula dentro de uma.", vbExclamation
        Exit Sub
    End If

    Set pf = pt.PivotFields(cmbCampos.Value)
    If pf Is Nothing Then
        MsgBox "Campo inválido. Por favor, selecione um campo válido.", vbExclamation
        Exit Sub
    End If

    linhas = Split(entradaTexto, vbNewLine)
    For Each valor In linhas
        If modoFlexivel Then valor = Trim(valor)
        If Len(valor) > 0 Then dict(CStr(valor)) = True
    Next valor

    For i = 1 To pf.PivotItems.Count
        todosVisiveis(CStr(pf.PivotItems(i).Name)) = True
    Next i

    For Each chaveValor In dict.Keys
        achou = False
        compararA = CStr(chaveValor)
        If modoFlexivel Then compararA = NormalizarTexto(compararA)

        For Each nomeItem In todosVisiveis.Keys
            compararB = CStr(nomeItem)
            If modoFlexivel Then compararB = NormalizarTexto(compararB)

            If compararA = compararB Then
                achou = True
                listaEncontrados(nomeItem) = True
                Exit For
            End If
        Next nomeItem

        If Not achou Then
            listaNaoEncontrados = listaNaoEncontrados & chaveValor & vbCrLf
        End If
    Next chaveValor

    If listaEncontrados.Count = 0 Then
        MsgBox "Nenhum valor colado corresponde exatamente a um valor visível do campo. Nada será filtrado!", vbExclamation
        Exit Sub
    End If

    If Len(listaNaoEncontrados) > 0 Then
        alerta = "Atenção: alguns valores não foram encontrados e foram ignorados no filtro." & vbCrLf & vbCrLf & _
                 "Deseja copiá-los para a área de transferência?"

        If MsgBox(alerta, vbYesNo + vbInformation, "Valores não encontrados") = vbYes Then
            Dim clip As New MSForms.DataObject
            clip.SetText listaNaoEncontrados
            clip.PutInClipboard
            MsgBox "Valores copiados para a área de transferência.", vbInformation
        End If
    End If

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error Resume Next

    With pf
        .ClearAllFilters
        .EnableMultiplePageItems = True

        For i = 1 To .PivotItems.Count
            .PivotItems(i).Visible = True
        Next i

        For i = 1 To .PivotItems.Count
    nomeItem = .PivotItems(i).Name
    If Not listaEncontrados.exists(CStr(nomeItem)) Then
        On Error Resume Next
        .PivotItems(i).Visible = False
        On Error GoTo 0
    End If
Next i
    End With

    On Error GoTo 0
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

调用模块代码 #

Public Sub MostrarPainelFiltro()
PivotFilterForm.Show vbModeless
End Sub

内容的提问来源于stack exchange，提问作者Fernando