0

I have been trying to code a VBA bulk filtering that works on different PivotTables formats, which includes both the usual ones and those ones with OLAP.

The point is that I am stuck in figuring out how to solve some OLAP major issues. The same procedure that calls pf.ClearAllFilters and loops through pf.PivotItems to show and / or hide data works flawlessly on the usuals PivotTables, but this is not what happens when I am dealing with the OLAP ones. I got some errors before I coud go further:

  • Error 438 (“Object doesn’t support this property or method”)
  • Error 05 (“Invalid procedure call or argument”) whenever I try to set pf.VisibleItemsList
  • and some compilation errors (“Method or data member not found”) every single time I try to call pf.CubeField properties

If any of you could help me out, I would appreciate to know how I could apply a multi-select filter on an OLAP PivotField, whether it is in Filters, Rows or Columns. Any tips about VisibleItemsList or HiddenItemsList (and SlicerCache as a way out) are also welcomed. Neither IAs could clarify what might potencially be wrong.

All I have done so far, you can check below:

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

There is a module as well where I used to attach any needed calls:

Public Sub MostrarPainelFiltro()
PivotFilterForm.Show vbModeless
End Sub

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.