Views

VBA Excel - Usando o MS Excel como banco de dados


Sim, às vezes nos é solicitado desenvolver uma solução no MS Excel que devia ser desenvolvida no MS Access. Precisamos desenvolver um formulários para dataentry, um ambiente para o armazenamento dos dados.

Imaginemos termos uma planilha com dados de Fornecedor e outra planilha de Produto. Como faríamos para trazer os produtos de um determinado fornecedor?

Todo o processo precisaria ser feito via código, um loop varrendo os produtos e identificando o fornecedor e copiando o resultado para outro lugar. Ou através do uso de fórmula, que dependendo da massa de dados pode se tornar inviável.

E se fosse possível fazer um SELECT com JOIN? Ficaria bem mais fácil certo?

Se seguíssemos um modelo de desenvolvimento padrão, o nosso código ficaria mais organizado. Precisamos de um segundo arquivo MS Excel pra ser o nosso banco de dados. Nada é perfeito, só é possível executar SELECT e INSERT. Os comandos de UPDATE e DELETE a gente improvisa.

Segue abaixo algumas funções que auxiliam no trabalho com o Excel como banco de dados. E certamente para outras versões do Excel devemos alterar a string de conexão.

Function ConectaXL() As Boolean
'*****************************************
'Nome: ConectaXL
'Autor: Rafael Gomes dos Santos
'Data: 04/05/2010
'Descrição: Conexão ADO com planilha Excel (só consulta)
'Revisão: 04/05/2010
'*****************************************

Let ConectaXL = True

On Error GoTo erro1:

With cn
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xlDB & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
    .Open
End With

erro1:

If Err.Number <> 0 Then
   
    Let ConectaXL = False
   
End If

End Function


Function DesconectaXL() As Boolean

'*****************************************
'Nome: DesconectaXL
'Autor: Rafael Gomes dos Santos
'Data: 04/05/2010
'Descrição: Desconecta ADO com planilha Excel
'Revisão: 04/05/2010
'*****************************************

On Error GoTo erro1:

    Let DesconectaXL = True

    cn.Close
   
    Set cn = Nothing
   
erro1:

If Err.Number <> 0 Then

    Let DesconectaXL = False

End If
   
End Function


Function ConectaXLAtualizavel() As Boolean

'*****************************************
'Nome: ConectaXLAtualizavel
'Autor: Rafael Gomes dos Santos
'Data: 04/05/2010
'Descrição: Conexão ADO com planilha Excel (Permite INSERT)
'Revisão: 04/05/2010
'*****************************************

Let ConectaXLAtualizavel = True

On Error GoTo erro1:

With cn
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xlDB & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes"";"
    .Open
End With

erro1:

If Err.Number <> 0 Then
   
    ConectaXLAtualizavel = False
   
End If

End Function


Function ExcluiRegistro( _
Tabela As String, _
Campo As String, _
Valor As String _
) As Boolean


    '*****************************************
    'Nome: ExcluiRegistro
    'Autor: Rafael Gomes dos Santos
    'Data: 04/05/2010
    'Descrição: Exclui registro de tabela na planilha banco de dados
    'Revisão: 04/05/2010
    '*****************************************


    Dim xl As New Excel.Application
    Dim wkb As Workbook
    Dim wsh As Worksheet
   
    Dim c As Integer
    Dim l As Integer
   
    Let ExcluiRegistro = False
   
    Set wkb = xl.Workbooks.Open(xlDB)

    Set wsh = wkb.Worksheets(Tabela)
   
    Let c = 1
   
    Do While wsh.Cells(1, c) <> ""

        If wsh.Cells(1, c) = Campo Then

            Exit Do
       
        End If

        Let c = c + 1

    Loop
   
    If wsh.Cells(1, c) <> "" Then
   
        Let l = 2
       
        Do Until wsh.Cells(l, c) = ""
   
            If wsh.Cells(l, c) = Valor Then
           
                wsh.Cells(l, c).EntireRow.Delete
                Let ExcluiRegistro = True
                Exit Do
               
            End If
   
            Let l = l + 1
       
        Loop
       
    End If

    Set wsh = Nothing
    wkb.Close True
    Set wkb = Nothing
    xl.Quit
    Set xl = Nothing

End Function


Function RegistroExiste( _
Tabela As String, _
Campo As String, _
Valor As String, _
Optional Tipo As String, _
Optional Campo2 As String, _
Optional Valor2 As String, _
Optional Tipo2 As String, _
Optional Campo3 As String, _
Optional Valor3 As String, _
Optional Tipo3 As String _
) As Boolean

    '*****************************************
    'Nome: RegistroExiste
    'Autor: Rafael Gomes dos Santos
    'Data: 04/05/2010
    'Descrição: Retorna TRUE se o registro existir na planilha banco de dados. Limitado a 3 parâmetros.
    'Revisão: 04/05/2010
    '*****************************************


    Dim rs As New ADODB.Recordset

    Dim strSQL As String

    RegistroExiste = False

    If ConectaXLAtualizavel = False Then
       
        MsgBox "Impossível conectar"
        Exit Function
   
    End If
   
    rs.ActiveConnection = cn
   
    Let strSQL = "SELECT * FROM [" & Tabela & "$] WHERE "
   
    If Tipo = "Number" Then
        strSQL = strSQL & Campo & " = " & Valor
    Else
        strSQL = strSQL & Campo & " = '" & Valor & "'"
    End If
   
    If Campo2 <> "" Then
        If Tipo2 = "Number" Then
            strSQL = strSQL & " " & Campo2 & " = " & Valor2
        Else
            strSQL = strSQL & " " & Campo2 & " = '" & Valor2 & "'"
        End If
    End If
   
    If Campo3 <> "" Then
        If Tipo3 = "Number" Then
            strSQL = strSQL & " " & Campo3 & " = " & Valor3
        Else
            strSQL = strSQL & " " & Campo3 & " = '" & Valor3 & "'"
        End If
    End If

    rs.Source = strSQL

    rs.LockType = adLockPessimistic
    rs.Open

    If Not rs.EOF Then
       
        RegistroExiste = True
        
    End If

    If DesconectaXL = False Then
       
        MsgBox "Impossível desconectar"
        Exit Function
   
    End If

End Function


Fazendo um SELECT com JOIN na planilha Excel.

    If ConectaXL = False Then
       
        MsgBox "Impossível conectar"
        Exit Sub
   
    End If
   
    Let rs.ActiveConnection = cn
   
      Let strsql = "SELECT [Jurado$].Nome,"
Let strsql = strsql & " [Jurado$].Cargo,"
Let strsql = strsql & " [Jurado$].Empresa,
Let strsql = strsql & " [Jurado$].CargoJuri"
Let strsql = strsql & " FROM [Jurado$]"
Let strsql = strsql & " INNER JOIN [CargoJuri$]"
Let strsql = strsql & " ON [Jurado$].CargoJuri = [CargoJuri$].Cargo"
Let strsql = strsql & " WHERE [Jurado$].RegiaoJuri = 'LESTE/OESTE'"
Let strsql = strsql & " ORDER BY [CargoJuri$].Ordem"

Let rs.Source = strsql
Let rs.LockType = adLockPessimistic
   
      rs.Open


    If ConectaXLAtualizavel = False Then
        MsgBox "Impossível conectar"
        Exit Sub
    End If
   
    Let rs.ActiveConnection = cn
   
    Let rs.Source = "SELECT * FROM [Inscritos$] WHERE" _
    & " Categoria = '" & Me.cmbCategoria & "'" _
    & " AND Regiao = '" & Me.cmdRegiao & "'" _
    & " AND Posicao = " & Me.txtPosicao
   
    Let rs.LockType = adLockPessimistic
    rs.Open
   
    If Not rs.EOF Then
    
        rs.MoveFirst
   
        Let rs("Categoria") = Me.cmbCategoria
        Let rs("Regiao") = Me.cmdRegiao
        Let rs("Duracao") = Me.txtDuracao
        Let rs("Posicao") = Me.txtPosicao
        Let rs("Titulo") = Me.txtTitulo
   
        rs.Update
        rs.Close
        Set rs = Nothing
   
    End If

    If DesconectaXL = False Then
        MsgBox "Não foi possível se desconectar do Banco de Dados. por favor reinicie o sistema."
        Exit Sub
    End If

Referência: SistemaEmVBA.com

Deixe os seus comentários! Envie este artigo, divulgue este link na sua rede social...



Tags: VBA, Excel, Icon, ícones, Conditional, Formatting, 




Nenhum comentário:
Tags: , , , , ,

VBA Excel - Convertendo em Imagens



Lembro-me de há alguns anos, quando criei um Blog específico de VBA. Recordo-me como era incipiente a inter-colaboração de códigos VBA no mercado nacional, bem como a utilização profissional de Dashboards e Scorecards. O desenvolvimento VBA naquela época restringia-se aos expressão "faz-se macros no excel'. 

Hoje, estamos vivenciando um mercado de desenvolvimento VBA mais maduro, cheio de profissionais competentíssimos (tomara que essa expressão não seja um neologismo), com inúmeras excelentes soluções de desenvolvimento e aplicações de automação. Encontramo-nos amadurecidos e prontos para avançarmos no nosso ciclo de aprimoramento profissional!

O artigo a seguir visa elevar a qualidade da nossa entrega. Enviar o conteúdo das nossas soluções para outros ambientes e interfaces. Das aplicações da suíte MS Office, a editores gráficos para a criação de Infográficos e até mesmo a inserção destes em páginas da Web de modo automático (Sharepoint). 

Abaixo seguem diversos códigos bem elaborados que possibilitarão copiar os gráficos das suas planilhas pré-existentes, bem como os ranges de dados destas (conjuntos de células previamente selecionados) como uma imagem. 

Detalhes:
Por vezes desejará não enviar a fonte de dados junto com o gráfico para um Slide que lhe solicitaram.

Talvez deseje enviar uma tabela, um relatório, partes de um Balanced Scorecard, um Dashboards ou um Scorecards, ou mesmo um conjunto deKPIs, sem que estes sejam alterados por quem recebê-los.

Criar um informativo regular, parte de um relatório, que envia via MS Outlook, comentários dos
relatórios, agregando conteúdo analítico e não apenas gráficos e dados estáticos para o público alvo.

Como fazê-lo?
Com os recursos abaixo alistados, poderá enviar somente as imagens, como se tirasse uma foto e colasse no Slide, num documento MS Word, num e-mail e até mesmo no Photoshop (há!). Chega! Essas são apenas algumas das possibilidades...Pensem em outras...
CÓDIGO: SELECIONAR TUDO
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture


Para copiar um gráfico selecionado (ou ativo) em uma planilha, implemente a seguinte sintaxe: 
CÓDIGO: SELECIONAR TUDO
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Copiando um range de dados, colando-a como uma imagem: 
CÓDIGO: SELECIONAR TUDO
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Copie gráficos selecionados (ou ativo) em uma planilha, implemente a seguinte sintaxe: 
CÓDIGO: SELECIONAR TUDO
Worksheets("Nome da pasta").ChartObjects(1).Chart.CopyPictureAppearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

Copie uma faixa de dados específica, embora não esteja selecionada, colando-a a posteriori: 
CÓDIGO: SELECIONAR TUDO
Worksheets("Nome da pasta").Range("B11:AF25").CopyPicture Appearance:=xlScreen, Format:=xlPicture

Pois é, sempre existem códigos admiráveis por aí: 
CÓDIGO: SELECIONAR TUDO
Sub GraficoToPowerPoint()
    Dim objPPT As Object
    Dim objPrs As Object
    Dim shtTemp As Worksheet
    Dim chtTemp As ChartObject
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.presentations.Open ThisWorkbook.Path & "\Dashboard_Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1 'ppViewSlide
     
    For Each shtTemp In ThisWorkbook.Worksheets
        For Each chtTemp In shtTemp.ChartObjects
            intSlide = intSlide + 1
            chtTemp.CopyPicture
            If intSlide > objPPT.presentations(1).Slides.Count Then
                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.presentations(1).Slides.Add(Index:=intSlide, Layout:=1).SlideIndex
            End If
            objPPT.ActiveWindow.View.Paste
        Next
    Next
    objPPT.presentations(1).Save
    objPPT.Quit
     
    Set objPrs = Nothing
    Set objPPT = Nothing
End Sub

Copiando range e gráfico para o MS Powerpoint: 
CÓDIGO: SELECIONAR TUDO
Sub GraficoRange_TO_Powerpoint() 
    Dim objPPT As Object 
    Dim objPrs As Object 
    Dim objSld As Object 
    Dim shtTemp As Object 
    Dim chtTemp As ChartObject 
    Dim objShape As Shape 
    Dim objGShape As Shape 
    Dim intSlide As Integer 
    Dim blnCopy As Boolean 
     
    Set objPPT = CreateObject("Powerpoint.application") 
    objPPT.Visible = True 
    objPPT.Presentations.Add 
    objPPT.ActiveWindow.ViewType = 1
     
    For Each shtTemp In ThisWorkbook.Sheets 
        blnCopy = False 
        If shtTemp.Type = xlWorksheet Then 
            For Each objShape In shtTemp.Shapes
                blnCopy = False 
                If objShape.Type = msoGroup Then 

                    For Each objGShape In objShape.GroupItems 
                        If objGShape.Type = msoChart Then 
                            blnCopy = True 
                            Exit For 
                        End If 
                    Next 
                End If 
                If objShape.Type = msoChart Then blnCopy = True 
                 
                If blnCopy Then 
                    intSlide = intSlide + 1 
                    objShape.CopyPicture 

                    objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                    objPPT.ActiveWindow.View.Paste 
                End If 
            Next 
            If Not blnCopy Then 

                intSlide = intSlide + 1 
                shtTemp.UsedRange.CopyPicture 

                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                objPPT.ActiveWindow.View.Paste 
            End If 
        Else 
            intSlide = intSlide + 1 
            shtTemp.CopyPicture 

            objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
            objPPT.ActiveWindow.View.Paste 
        End If 
    Next 
     
    Set objPrs = Nothing 
    Set objPPT = Nothing 
End Sub

Bônus: 
CÓDIGO: SELECIONAR TUDO
Sub RangeUsado_TO_Powerpoint()
    Dim objPPT As Object
    Dim shtTemp As Object
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Open ThisWorkbook.Path & "\Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1
    
    For Each shtTemp In ThisWorkbook.Sheets
        shtTemp.Range("A1", shtTemp.UsedRange).CopyPicture xlScreen, xlPicture
        intSlide = intSlide + 1

        objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
        objPPT.ActiveWindow.View.Paste
        With objPPT.ActiveWindow.View.Slide.Shapes(objPPT.ActiveWindow.View.Slide.Shapes.Count)
            .Left = (.Parent.Parent.SlideMaster.Width - .Width) / 2
        End With
    Next
     
    Set objPPT = Nothing
End Sub


Tags: VBA, Excel, copy, object, objeto, copiar, chart, gráfico





Nenhum comentário:
Tags: , , , , , , ,
Assinar: Postagens (Atom)
diHITT - Notícias