Formatar tabela dinâmica Excel automaticamente

Objetivo: Formatar tabela dinâmica Excel automaticamente. VBA Excel.

Formatar tabela dinâmica automaticamente

No dia-a-dia muitas vezes a tabela dinâmica resolve nossos problemas, sendo uma das ferramentas mais úteis que o Excel nos oferece.

Com ela podemos sumarizar os dados e apresentá-los das mais diversas formas e com várias opções, mas há sempre formatações que realizamos sempre que as criamos.

Um exemplo disto é a alteração do nome dos campos de valor inseridos, retirando o “Contagem de” e o “Soma de”, e além disso formatando para repetir os valores das listas e formatar os valores para que fiquem no formato de Número separado por ponto e com duas casas decimais. Tudo isso consome tempo.

Encontrei um código VBA no site chandoo.org, ao qual realizei algumas alterações, colocando em português e acrescentando outras formatações que achava interessante.

Este código realiza uma formatação padrão na sua tabela dinâmica, bastando para isso você criar sua tabela dinâmica e, selecionando uma das suas células, executar a macro.

Veja neste artigo como copiar os procedimentos acima e incluir na sua pasta pessoal de Macros neste artigo: http://guiadoexcel.com.br/habilitando-a-guia-desenvolvedor-e-copiando-procedimentos-vba-sub-da-internet

Veja neste outro artigo como criar botões de atalho para os procedimentos criados para que eles fiquem conforme abaixo: http://guiadoexcel.com.br/criar-botoes-de-atalho-para-macros-e-procedimento-vba.

Abaixo o código fonte devidamente comentado e com as alterações citadas acima:

 

Sub InstantPivot()

'Baseado no site chandoo.org
'   Programmer:     Jeff Weir
'   Contact:        weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz

'Formata a tabela dinâmica com sua formatação preferida, formatação default

'Configurações realizadas
'   1.  Mostrar de forma tabulada os dados
'   2.  Ligar a opção de repetir linhas
'   3.  Desliga os subtotais
'   4.  Liga o total final de coluna
'   5.  Desliga a opção de ajustar a tabela dinâmica
'   7.  Desliga a opção de salvar os dados da tabela dinâmica como arquivo
'   8.  Formata os campos de soma de valor no formato decimal separado por ponto
'   9.  Ajusta as colunas da tabela dinâmica
'   10. Retira do nome dos valores as descrições Contagem, Soma

    Dim pc As PivotCache
    Dim pf As PivotField
    Dim pt As PivotTable
    Dim lo As ListObject
    Dim rng As Range
    Dim strLabel As String
    Dim strFormat As String
    Dim i As Long
    Dim wksSource As Worksheet

    
    'Verifica se estamos lidando com uma versão do Excel que suporta ListObjects
    'Versões superiores ao Excel 2007
    If Application.Version >= 14 Then
    

        On Error Resume Next
        Set pt = ActiveCell.PivotTable
        On Error GoTo errhandler
        If pt Is Nothing Then
            Set lo = ActiveCell.ListObject
            If lo Is Nothing Then Set lo = ActiveSheet.ListObjects.Add(xlSrcRange, Selection.CurrentRegion, , xlYes)
            Set rng = Cells(ActiveSheet.UsedRange.Row, ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column + 1)
            Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo)
            Set pt = pc.CreatePivotTable(TableDestination:=rng)
        Else:
            'Verifica se o objeto pt é baseado em um ListObject.
            '  *  Se for, definir como ListObject
            '  *  Se não, retorna os dados para um ListObject
            On Error Resume Next
            Set lo = Range(pt.SourceData).ListObject
            On Error GoTo errhandler
            If lo Is Nothing Then
                Set rng = Application.Evaluate(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))
                Set wksSource = rng.Parent
                Set lo = wksSource.ListObjects.Add(xlSrcRange, rng, , xlYes)
                pt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo.Name)
            End If
    
        End If
    
        With pt
            .ColumnGrand = True
            .RowGrand = False
            .RowAxisLayout xlTabularRow
            .RepeatAllLabels xlRepeatLabels
            .ShowTableStyleRowHeaders = False
            .ShowDrillIndicators = False
            .HasAutoFormat = False
            .SaveData = False
            .ManualUpdate = True
            If ActiveCell.CurrentRegion.Cells.Count > 1 Then
                For i = 1 To .PivotFields.Count - .DataFields.Count 'The .DataField.Count bit is just in case the pivot already exists
                    Set pf = .PivotFields(i)
                    With pf
                        If pf.Name  "Values" Then
                            .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                            On Error Resume Next
                            .NumberFormat = lo.DataBodyRange.Cells(1, i).NumberFormat
                            On Error GoTo errhandler
                        End If
                    End With
                Next i
            End If
        End With
        
        ' Obter DataFields para coincidir com a formatação do campo de origem
        ' Note-se que isso só vai ser necessárias no caso de que estamos
        ' executando este código em uma tabela dinâmica já existente
        On Error GoTo errhandler
        If pt.DataFields.Count > 0 Then
            For Each pf In pt.DataFields
                If pf.Function  xlCount Then pf.NumberFormat = "#,##0.00" 'pt.PivotFields(pf.SourceName).NumberFormat
                ' Acabar com 'Soma de', se possível
                On Error Resume Next
                pf.Caption = pf.SourceName & " "
                On Error GoTo errhandler
            Next pf
        End If
    
        'Calcula e atualiza a tela
         With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = xlAutomatic
        End With
          
        With pt
            .ManualUpdate = False
            .TableRange2.Select
        End With
        
        pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
        
        ActiveCell.CurrentRegion.EntireColumn.AutoFit

    'Tratamento de erros
    Err.Clear
errhandler:
            If Err.Number > 0 Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                    .Calculation = xlAutomatic
                End With
                MsgBox "Atenção, ocorreu um erro: Error#" & Err.Number & vbCrLf & Err.Description _
                         , vbCritical, "Error", Err.HelpFile, Err.HelpContext
            End If
    End If
    
End Sub

Abraço

Marcos Rieper