Marcar vários filtros na tabela dinâmica automaticamente – VBA

Objetivo: Marcar vários filtros na tabela dinâmica automaticamente – VBA.

Esta planilha foi criada pelo meu amigo Edney Nascimento, ao qual agradeço pela colaboração com o site.

A planilha consiste em marcar nas checkbox as marcações dos dias nas tabelas dinâmicas de forma automática.

Abaixo o código fonte:

Sub AtualizarDia()
On Error GoTo ErroAtualizarDia

Dim PrimeiraLinhaDW As Long, UltimaLinhaDW As Long, NomeTabelaDW As String

PrimeiraLinhaDW = 2
UltimaLinhaDW = Sheets("PARAMETROS").Cells(2, 1).End(xlDown).Row

'Executa o processo conforme a quantidade de tabelas dinâmicas existentes
For i = PrimeiraLinhaDW To UltimaLinhaDW
     NomeTabelaDW = Sheets("PARAMETROS").Cells(i, 1).Text
     
     'Atualiza a tabela dinâmica somente na 1ª vez que o processo é executado
     If i = 2 Then
          ActiveSheet.PivotTables(NomeTabelaDW).PivotCache.Refresh
     End If

     'Limpa os filtros
     ActiveSheet.PivotTables(NomeTabelaDW).PivotFields("Dia").ClearAllFilters

     'Executa o processo para cada um dos dias do mês
     For j = 1 To 31
          ActiveSheet.PivotTables(NomeTabelaDW).PivotFields("DIA").PivotItems(j).Visible = Worksheets("PARAMETROS").Cells(j + 1, 6).Value
     Next j
     
Next i

Fim:
     Exit Sub

ErroAtualizarDia:
    
     If Err.Number = 1004 Then
          Resume Next
     Else
          Mensagem = Err.Number & " " & Err.Description
          MsgBox Mensagem, vbInformation, Titulo
     End If

End Sub


Sub MarcarTudo()

For i = 2 To 32
     Sheets("PARAMETROS").Cells(i, 5).Value = True
Next i
     
End Sub

Sub DesmarcarTudo()

For i = 2 To 32
     Sheets("PARAMETROS").Cells(i, 5).Value = False
Next i

End Sub

DIGITE O SEU EMAIL PARA FAZER O DOWNLOAD DOS ARQUIVOS: Baixe a planilha

Abraço

Marcos Rieper