MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Exportar para Excel e formatar algumas colunas

    baldocchi
    baldocchi
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 125
    Registrado : 03/11/2014

    Exportar para Excel e formatar algumas colunas Empty Exportar para Excel e formatar algumas colunas

    Mensagem  baldocchi em 17/6/2019, 20:14

    Olá a todos,

    Eu peguei o exemplo do JPAULO e alterei um pouco para exportar alguns dados para o Excel e formatar a primeira linha, colocar decimais na coluna D e autoajuste em todas as colunas.
    O Exemplo verifica se o arquivo existe no Desktop usuário e, caso existe apenas o preenche, senão, cria o arquivo e o preenche.

    Sei que parece amador, mas não conheço muito de VBA. De qualquer forma espero que ajude alguém.


    Código:
    Dim db As DAO.DATABASE
    Dim strConta As String
    Dim xls As Object
    Dim rst As DAO.Recordset
    Dim strSQL
    Dim intUltimaCelula%
    Dim xlsht As Excel.Worksheet
    Dim strCaminho As String
    Dim verCaminho As String

    Set db = CurrentDb
    Set xls = CreateObject("Excel.Application")

     strCaminho = VBA.Environ("userprofile") & "\desktop\"

    strConta = strCaminho & "SaldosDeContasCorrentes.xlsx"

    verCaminho = Dir(strConta)
      'verifica se o arquivo existe no desktop do usuário
       If verCaminho = "SaldosDeContasCorrentes.xlsx" Then
               xls.Workbooks.Open (strConta)
                   Set xlsht = xls.Worksheets(1) ' 1 é a primeira planilha
               xls.Visible = True 'torna o excel visivel
               
               strSQL = "SELECT tSaldoCC.ContaCorrente AS ContaCorrente, tSaldoCC.DataSaldo AS DataSaldo, tSaldoCC.ProgEsp AS Programa, tSaldoCC.SaldoConta AS SaldoConta   " & _
                        "FROM tSaldoCC " & _
                        "WHERE ContaCorrente <> NULL AND DataSaldo>=#1/1/2019# " & _
                        "ORDER BY tSaldoCC.ContaCorrente, tSaldoCC.DataSaldo DESC, tSaldoCC.ProgEsp"
               
               Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
               
               If rst.RecordCount = 0 Then Exit Sub 'se não tem registros, morre aqui
                   xls.Worksheets(1).Activate
                   xls.ActiveSheet.Range("A1").Select 'seleciona a primeira celula
                   xls.ActiveSheet.Range("A1").Value = "CONTA"
                   xls.ActiveSheet.Range("A1").Font.Bold = True
                   xls.ActiveSheet.Range("B1").Value = "DATA"
                   xls.ActiveSheet.Range("B1").Font.Bold = True
                   xls.ActiveSheet.Range("C1").Value = "PROGRAMA"
                   xls.ActiveSheet.Range("C1").Font.Bold = True
                   xls.ActiveSheet.Range("D1").Value = "SALDO"
                   xls.ActiveSheet.Range("D1").Font.Bold = True
               
                       intUltimaCelula = xlsht.Cells(xlsht.Rows.Count, 1).End(xlUp).Row 'obtem a ultima celula preenchida
                       intUltimaCelula = intUltimaCelula + 1 'acrescenta mais uma celula, que será a vazia
                       xls.ActiveSheet.Range("A" & intUltimaCelula).Select 'seleciona-a
               
                       xls.ActiveCell.CopyFromRecordset rst 'copia os dados da tabela
               
                       xls.ActiveSheet.Columns("D").NumberFormat = "#,##0.00"
                       xls.ActiveSheet.Columns("A").AutoFit
                       xls.ActiveSheet.Columns("B").AutoFit
                       xls.ActiveSheet.Columns("C").AutoFit
                       xls.ActiveSheet.Columns("D").AutoFit
               
               'fecha o recordset e limpa a memoria
               rst.Close: Set rst = Nothing
               'salva o excel
               xls.ActiveWorkbook.Save
               'fecha o excel
               xls.Application.Quit
               'limpa a memoria
               Set xls = Nothing
           Else
                   'Cria o arquivo caso ele não exista
                   Dim newbook As Object
                   Set newbook = Workbooks.Add
                   With newbook
                       .SaveAs FileName:=strConta
                   End With
               
                       xls.Workbooks.Open (strConta)
                           Set xlsht = xls.Worksheets(1) ' 1 é a primeira planilha
                       xls.Visible = True 'torna o excel visivel
                       
                       strSQL = "SELECT tSaldoCC.ContaCorrente AS ContaCorrente, tSaldoCC.DataSaldo AS DataSaldo, tSaldoCC.ProgEsp AS Programa, tSaldoCC.SaldoConta AS SaldoConta   " & _
                                "FROM tSaldoCC " & _
                                "WHERE ContaCorrente <> NULL AND DataSaldo>=#1/1/2019# " & _
                                "ORDER BY tSaldoCC.ContaCorrente, tSaldoCC.DataSaldo DESC, tSaldoCC.ProgEsp"
                       
                       Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
                       
                       If rst.RecordCount = 0 Then Exit Sub 'se não tem registros, morre aqui
                           xls.Worksheets(1).Activate
                           xls.ActiveSheet.Range("A1").Select 'seleciona a primeira celula
                           xls.ActiveSheet.Range("A1").Value = "CONTA"
                           xls.ActiveSheet.Range("A1").Font.Bold = True
                           xls.ActiveSheet.Range("B1").Value = "DATA"
                           xls.ActiveSheet.Range("B1").Font.Bold = True
                           xls.ActiveSheet.Range("C1").Value = "PROGRAMA"
                           xls.ActiveSheet.Range("C1").Font.Bold = True
                           xls.ActiveSheet.Range("D1").Value = "SALDO"
                           xls.ActiveSheet.Range("D1").Font.Bold = True
                       
                               intUltimaCelula = xlsht.Cells(xlsht.Rows.Count, 1).End(xlUp).Row 'obtem a ultima celula preenchida
                               intUltimaCelula = intUltimaCelula + 1 'acrescenta mais uma celula, que será a vazia
                               xls.ActiveSheet.Range("A" & intUltimaCelula).Select 'seleciona-a
                       
                               xls.ActiveCell.CopyFromRecordset rst 'copia os dados da tabela
                       
                               xls.ActiveSheet.Columns("D").NumberFormat = "#,##0.00"
                               xls.ActiveSheet.Columns("A").AutoFit
                               xls.ActiveSheet.Columns("B").AutoFit
                               xls.ActiveSheet.Columns("C").AutoFit
                               xls.ActiveSheet.Columns("D").AutoFit
                       
                       'fecha o recordset e limpa a memoria
                       rst.Close: Set rst = Nothing
                       'salva o excel
                       xls.ActiveWorkbook.Save
                       'fecha o excel
                       xls.Application.Quit
                       'limpa a memoria
                       Set xls = Nothing
       End If
    avatar
    renpv
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 323
    Registrado : 12/01/2015

    Exportar para Excel e formatar algumas colunas Empty Re: Exportar para Excel e formatar algumas colunas

    Mensagem  renpv em 17/6/2019, 23:09

    Obrigado por compartilhar. E parabéns pela iniciativa.

      Data/hora atual: 1/12/2020, 17:48