BI com tabelas dinâmicas

Ano novo, e primeira postagem dele depois de um bom tempo sem postar , espero que consiga escrever mais por aqui.

Mas agora vamos ao que interessa!

É muito comum em nosso dia a dia realizar diversas conexões para obtenção de dados; sejam elas para pastas de trabalho, arquivos Access , SQL, Oracle ou qualquer outro banco de dados.

O Excel possui uma ferramenta poderosíssima para realizar analise de dados, a tabela dinâmica. Com ela  faremos o BI diretamente no Excel, com isto conseguimos extrair dados diversos da base de dados e apresentar múltiplas visões para o usuário.

Para isto desenvolvi rotina a seguir que recebe dois parâmetros :

rs - Um objeto do tipo ADODB.Recordset, que contém os dados necessários para a utilização na tabela dinâmica

MakeNewFile - Uma string opcional que caso seja enviada para esta rotina indica o caminho da pasta de trabalho que deve ser atualizada, caso não será criado um novo arquivo nela, nele será  criada uma planilha nomeada  base onde estarão os dados vindos do recordset recebido.

Sub MakePivotTable(rs As ADODB.Recordset, Optional MakeNewFile As String = vbNullString)
'desenvolvida por Bruno Leite
'officevb.com

On Error GoTo werro

Dim EX As Object, WB As Object, sht As Object
Dim strSQL As String, strMsg As String
      
      'caso o recordset não contenha dados
      If rs.EOF Then
            MsgBox "Não foram encontrados dados para o relatório!", vbInformation
            Exit Sub
      Else
      'caso tenha
            Set EX = CreateObject("Excel.Application")
            
            'caso o argumento tenha sido omtido crie um novo arquivo
            If MakeNewFile = vbNullString Then
                  Set WB = EX.Workbooks.Add
                  strMsg = " Criada "
            Else
                  'Abra o arquivo
                  Set WB = EX.Workbooks.Open(MakeNewFile)
                  strMsg = " Atualizada "
            End If
            
            'caso a planilha não exista o código será desviado para o final pois ocorrerá um erro
            WB.Sheets("Base").Select
            
            Set sht = WB.Sheets("Base")
            
            'limpe os dados da planilha Base
            sht.Cells.ClearContents
            
            'Recuperando o nome dos campos vindos do recordset
            For i = 0 To rs.Fields.Count - 1
                  sht.Range("A1").Offset(0, i) = rs.Fields(i).Name
            Next i
            
            sht.[1:1].Font.Bold = True
            
            'copiando os dados
            sht.Range("A2").CopyFromRecordset rs
                  
            'Atualizando tabelas dinamicas
            
            'Criando intervalo nomeado com os dados
            'Este intervalo será a origem dos dados nas tabelas dinâmicas
            WB.Names.Add Name:="DADOS_REPORT", RefersToLocal:="=DESLOC(Base!$A$1;0;0;CONT.VALORES(Base!$A:$A);CONT.VALORES(Base!$1:$1))"
            
            Set sht = WB.Sheets(2)
            
            'caso não existam tabelas dinâmicas no arquivo, crie uma
            If WB.PivotCaches.Count = 0 Then
                  sht.PivotTableWizard xlDatabase, "DADOS_REPORT", sht.Range("B6")
            End If
      
            'procurando as tabelas dinamicas
            For Each sht In WB.Sheets
            'Atualizando as tabelas dinamicas para o novo intervalo caso necessário
                  For Each Pvt In sht.PivotTables
                        If Pvt.SourceData <> "DADOS_REPORT" Then
                            Pvt.ChangePivotCache WB.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="DADOS_REPORT", Version:=xlPivotTableVersion10)
                        End If
                        Pvt.RefreshTable
                  Next Pvt
            Next sht
      
      End If
      
'WB.Save

MsgBox "Pasta de Trabalho " & strMsg & " com sucesso!", vbInformation

EX.Visible = True

Exit Sub

werro:
'Caso a Planilha não exista ocorrerá um erro, crie a planilha e retorne ao ponto onde ocorreu o erro
If Err.Number = 9 Then
      WB.Sheets.Add after:=WB.Sheets(WB.Sheets.Count)
      WB.Sheets(WB.Sheets.Count).Name = "Base"
      Resume
'Caso a Conexão não esteja ativa
ElseIf Err.Number = 91 Then
      MsgBox "Não Conectado...Tente novamente mais tarde!", vbInformation
      Exit Sub
'Erro desconhecido
Else
      WB.Close False
      EX.Quit
      MsgBox "Não foi possível gerar o relatório!", vbInformation
End If

End Sub

Acredito que a rotina está bem simples de ser usada mas qualquer é só me escrever.

Abraço e até breve!