[Resolvido]Importar campos específicos para uma tabela Access de um Ficheiro Excell

Código:

    Dim rs As Recordset, N As Integer, oApp As Object, Lista As String

    Set rs = CurrentDb.OpenRecordset("tbl")
    Set oApp = CreateObject("Excel.Application")
    N = 10

    oApp.workbooks.Open CurrentProject.Path & "\Bradesco_24012014_122652.xls"
    oApp.Visible = False
    oApp.Worksheets("Sheet0").Activate

    Do While oApp.ActiveSheet.Range("A" & N) <> "total"
        Lista = Lista & "A" & N & " - " & oApp.ActiveSheet.Range("A" & N) & vbCrLf
        N = N + 1
    Loop

    Me.txtResultado = Lista

    rs.Close
    Set rs = Nothing

    oApp.Application.Quit
    Set oApp = Nothing

Código:

   Dim rs As Recordset, N As Integer, oApp As Object, Lista As String, uCell As Double

    Set rs = CurrentDb.OpenRecordset("tbl")
    Set oApp = CreateObject("Excel.Application")

    oApp.workbooks.Open CurrentProject.Path & "\Bradesco_24012014_122652.xls"
    oApp.Visible = False
    oApp.Worksheets("Sheet0").Activate

    uCell = oApp.Worksheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row ' uCell será o número da última célula não nula da coluna A

    For N = 10 To uCell
        If IsDate(oApp.ActiveSheet.Range("A" & N)) Then
            Lista = Lista & "A" & N & " - " & oApp.ActiveSheet.Range("A" & N) & vbCrLf
        End If
    Next

    Me.txtResultado = Lista

    rs.Close
    Set rs = Nothing

    oApp.Application.Quit
    Set oApp = Nothing

Código:

rs!Data = Mid(oApp.ActiveSheet.Range("A" & N), 1, 3) & Mid(oApp.ActiveSheet.Range("A" & N), 4, 3) & Mid(oApp.ActiveSheet.Range("A" & N), 7, 4)

Private Sub btnImpExtrato_Click()
      Dim MSG         As String
      '-----------------------------------------------------------------------------------
      'Se não fora selecionado um banco na caixa de combinação emite aviso e encerra a sub
      '-----------------------------------------------------------------------------------
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10    On Error GoTo TrataErro
      Dim NomeProcedimento As String
20        NomeProcedimento = "btnImpExtrato_Click"
          'Adiciona o nome do procedimento à função
30        PegaProcedimento (NomeProcedimento)
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
40    If Len("" & Me.cboBanco) = 0 Then
50        MsgBox "É necessário selecionar um banco!", vbCritical, "ATENÇÃO"
60        Me.cboBanco.SetFocus
70        Me.cboBanco.Dropdown
80        Exit Sub
90    End If
      '--------------------------------------------------
      'Mensagem de confirmação para importação do extrato
      '--------------------------------------------------
100   MSG = MsgBox("Deseja importar o extrato do Excell?", vbYesNo + vbQuestion, "IMPORTAR EXTRATO")
110       Select Case MSG
              Case vbYes
                  '---------------------------------------------
                  'Ativa a mensagem de aviso sobre  a importação
                  '---------------------------------------------
120               Me.lbAviso.Visible = True
130               Me.lbAviso.Caption = "Aguarde, importando extrato...."
                  '-------------------------------------
                  'Aplica a ampulheta no cursor do mouse
                  '-------------------------------------
140               Screen.MousePointer = 11
                  '*****************************************************************
                  'Códigos para abrir o arquivo
                  Dim Caminho As String, StrArquivo As String
                  Dim Titulo As String, filtro As String, NovoCaminho As String
                  
150               filtro = "Arquivos do Excell (*.xls)" & Chr(0) & "*.xls" & Chr(0)
160               Titulo = "Selecione o Extrato..."
170               Caminho = "C:\"
180               Caminho = LocalizarArquivo(Caminho, Titulo, filtro)
190               StrArquivo = Mid(Caminho, InStrRev(Caminho, "\") + 1)
200               Me.txtCaminho = Caminho
210               Me.txtArquivo = StrArquivo
                  
                  '------------------------------------------------
                  'Variáveis para a importação do arquivo em excell
                  '------------------------------------------------
                  Dim N As Integer, oApp As Object, Lista As String, uCell As Double
                  '---------------------------------------------------------
                 'Variáveis que receberão a informação das células do Excell
                  '---------------------------------------------------------
                  Dim ID_Banco As Byte, dblCredito As Double, dblDebito As Double, StrHistorico As String, StrDoc As String
                  Dim nCount As Integer, dtData
                  '-----------------------
                  'Seto o objeto do Excell
                  '-----------------------
220               Set oApp = CreateObject("Excel.Application")
                  '-------------------------------------------------
                  'Abre a caixa de diálogo para selecionar o arquivo
                  '-------------------------------------------------
                  
                  
                  'StrTable = "tblExemplo" 'nome da tabela no seu banco
230               oApp.Workbooks.Open Me.txtCaminho
240               oApp.Visible = False
250               oApp.Worksheets("Sheet0").Activate

260               uCell = oApp.Worksheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row ' uCell será o número da última célula não nula da coluna A

270               For N = 11 To uCell
                 ' MsgBox oApp.ActiveSheet.Range("A" & N) & "- " & oApp.ActiveSheet.Range("B" & N)
                      '-------------------------------------------------
                      'Verifico se a célula contém um campo do tipo Data
                      '-------------------------------------------------
280                   If IsDate(oApp.ActiveSheet.Range("A" & N)) Then
                          '------------------------------------------------------------------
                          'Verifica o comprimento dos ranges Credito e Debito para em sendo 0
                          'remeterá para o rótulo continua
                          '------------------------------------------------------------------
290                       If Len("" & oApp.ActiveSheet.Range("C" & N)) = 0 And Len("" & oApp.ActiveSheet.Range("D" & N)) = 0 Then
300                           GoTo Pula
310                       End If
                          '---------------------------------------------------------------------------
                          'Verifico o comprimento do Range Credito na planilha, em sendo 0 é um débito
                          '---------------------------------------------------------------------------
320                       If Len("" & oApp.ActiveSheet.Range("D" & N)) > 0 Then
                              '----------------------------------------------------------------------
                              'Aplica nas variáveis os respectivos valores condizentes com as células
                              '----------------------------------------------------------------------
330                           ID_Banco = Me.cboBanco.Column(0)
340                           dtData = oApp.ActiveSheet.Range("A" & N)
350                           StrHistorico = oApp.ActiveSheet.Range("B" & N)
360                           StrDoc = oApp.ActiveSheet.Range("C" & N)
370                           dblCredito = oApp.ActiveSheet.Range("D" & N)
380                           dblDebito = 0
                              '---------------------------
                              'Insere os valores na tabela
                              '---------------------------
390                           CurrentDb.Execute "INSERT INTO tblMovimento_Banco (idCaixa, Historico, DataMovimento, ValorCredito, ValorDebito, NumDoc, TipoDoc, cpTipoID)" _
                                              & "Values (""" & ID_Banco & """, """ & StrHistorico & """, """ & dtData & """, """ & dblCredito & """," _
                                              & """" & dblDebito & """, """ & StrDoc & """,'1', '1')"
400                       Else
                              '----------------------------------------------------------------------
                              'Aplica nas variáveis os respectivos valores condizentes com as células
                              '----------------------------------------------------------------------
410                           ID_Banco = Me.cboBanco.Column(0)
420                           dtData = oApp.ActiveSheet.Range("A" & N)
430                           StrHistorico = oApp.ActiveSheet.Range("B" & N)
440                           StrDoc = oApp.ActiveSheet.Range("C" & N)
450                           dblCredito = 0
460                           dblDebito = Mid(oApp.ActiveSheet.Range("E" & N), 2, Len(oApp.ActiveSheet.Range("E" & N)))
                              '---------------------------
                              'Insere os valores na tabela
                              '---------------------------
470                           CurrentDb.Execute "INSERT INTO tblMovimento_Banco (idCaixa, Historico, DataMovimento, ValorCredito, ValorDebito, NumDoc, TipoDoc, cpTipoID)" _
                                              & "Values (""" & ID_Banco & """, """ & StrHistorico & """,""" & dtData & """, """ & dblCredito & """," _
                                              & """" & dblDebito & """, """ & StrDoc & """,'2', '1')"
480                       End If
490                   End If
                      '----------------------------------------------------------
                      'Incrementa o contador para verificar a última linha válida
                      '----------------------------------------------------------
500                   nCount = nCount + 1
      '-----------------------------------------------------------------------------------
      'Rótulo par aonde é direcionado o código caso os ranges Credito e Debito sejam nulos
      '-----------------------------------------------------------------------------------
Pula:
510               Next
                  '---------------------------------------------------------
                  'Adiciona na tabela o registro da última importação valida
                  '---------------------------------------------------------
520               CurrentDb.Execute "INSERT INTO tblMarcaDiaExtrato (Banco_ID, cpDataUltimaImportacao, cpDescricao, cpNumDoc, cpNomeArquivo) Values " _
                                  & " (""" & ID_Banco & """, #" & dtData & "#, """ & StrHistorico & """,""" & StrDoc & """, """ & Me.txtArquivo & """)"
                  '-------------------------------------
                  'Remove a ampulheta no cursor do mouse
                  '-------------------------------------
530               Screen.MousePointer = 0
                  '---------------------
                  'Mensagem de conclusão
                  '---------------------
540               MsgBox "Extrato importado com Sucesso!", vbInformation, "PRONTO"
                  '-----------------------------------------------
                  'Destiva a mensagem de aviso sobre  a importação
                  '-----------------------------------------------
550               Me.lbAviso.Visible = False
                  '--------------------------------------------
                  'Termina a aplicação Excell e limpa ao objeto
                  '--------------------------------------------
560               oApp.Application.Quit
570               Set oApp = Nothing
580           Case vbNo
590       End Select
600   Exit Sub
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      'Tratamento de Erros
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Exit_TrataErro:
610       DoCmd.Hourglass False
620       DoCmd.Echo True
630   Exit Sub
TrataErro:
640       Select Case err.Number
              Case 1004
                  '-----------------------------------------------------
                  'Emite mensagem de erro visto que o objeto Rows falhou
                  '-----------------------------------------------------
650               MsgBox "É necessário fechar e reabrir o formulário", vbCritical, "ERRO NA PLANILHA"
                  '--------------------------------------------
                  'Termina a aplicação Excell e limpa ao objeto
                  '--------------------------------------------
660               oApp.Application.Quit
670               Set oApp = Nothing
                  '-------------------------------------
                  'Remove a ampulheta no cursor do mouse
                  '-------------------------------------
680               Screen.MousePointer = 0
                  '---------------------
690               MsgBox "Cancelado pelo Usuário!", vbInformation, "CANCELADO"
700               Exit Sub
710           Case Else
720             DoCmd.Hourglass False
730             DoCmd.Echo True
               'Chama a função global de tratamento de erros
740            GlobalErrHandler (Me.Name)
750            Resume Exit_TrataErro
760       End Select
End Sub

Código:

    Set oApp = GetObject(, "Excel.Application") ' Tentamos capturar o objeto.

    If oApp Is Nothing Then ' Se o objeto ainda não existir...
        Set oApp = CreateObject("Excel.Application") ' ... mandamos criá-lo.
    End If

Código:

    On Error GoTo Terro

    Dim rs As Recordset, N As Integer, oApp As Object, uCell As Double

    Set oApp = GetObject(, "Excel.Application")

    If oApp Is Nothing Then
        Set oApp = CreateObject("Excel.Application")
    End If

...
...
...

TErro:
    If Err.Number = 0 Or Err.Number = 20 Or Err.Number = 429 Then
        Resume Next
    Else
        MsgBox Err.Number & " - " & Err.Description
    End If

Para automatizar o Microsoft Excel, você estabelece uma variável de objeto que geralmente refere-se ao objeto aplicativo ou o objeto de pasta de trabalho do Excel. Outras variáveis de objeto podem ser definidas para fazerem referência a uma planilha, ou outros objetos no modelo de objeto do Microsoft Excel. Ao escrever um código para usar um objeto, método ou propriedade do Excel você sempre deve preceder a chamada com a variável de objeto apropriado. Se você não o fizer o Visual Basic estabelece sua própria referência para o Excel. Essa referência pode causar problemas quando você tentar executar o código de automação diversas vezes. Observe que mesmo se o código de linha começar com a variável de objeto, uma chamada pode ser feita para um objeto, método ou propriedade do Excel, no meio da linha de código que não está precedida com uma variável de objeto.

Código:

xlSheet.Range(Cells(1,1),Cells(10,2)).Value = "Hello"
               

Código:

xlSheet.Range(xlSheet.Cells(1,1),xlSheet.Cells(10,2)).Value = "Hello"      

Private Sub btnImpExtrato_Click()
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10    On Error GoTo TrataErro
      Dim NomeProcedimento As String
20        NomeProcedimento = "btnImpExtrato_Click"
          'Adiciona o nome do procedimento à função
30        PegaProcedimento (NomeProcedimento)
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      Dim MSG         As String
      Dim StrDestino As String, StrOrigem As String
      '-----------------------------------------------------------------------------------
      'Se não fora selecionado um banco na caixa de combinação emite aviso e encerra a sub
      '-----------------------------------------------------------------------------------
40    If Len("" & Me.cboBanco) = 0 Then
50        MsgBox "É necessário selecionar um banco!", vbCritical, "ATENÇÃO"
60        Me.cboBanco.SetFocus
70        Me.cboBanco.Dropdown
80        Exit Sub
90    End If
      '--------------------------------------------------
      'Mensagem de confirmação para importação do extrato
      '--------------------------------------------------
100   MSG = MsgBox("Deseja importar o extrato do Excel?", vbYesNo + vbQuestion, "IMPORTAR EXTRATO")
110       Select Case MSG
              Case vbYes
                  '---------------------------------------------
                  'Ativa a mensagem de aviso sobre  a importação
                  '---------------------------------------------
120               Me.lbAviso.Visible = True
130               Me.lbAviso.Caption = "Aguarde, importando extrato...."
                  '-------------------------------------
                  'Aplica a ampulheta no cursor do mouse
                  '-------------------------------------
140               Screen.MousePointer = 11
                  '-------------------------------------------------
                  'Abre a caixa de diálogo para selecionar o arquivo
                  '-------------------------------------------------
                  Dim Caminho As String, StrArquivo As String
                  Dim Titulo As String, filtro As String, NovoCaminho As String
                  
150               filtro = "Arquivos do Excell (*.xls)" & Chr(0) & "*.xls" & Chr(0)
160               Titulo = "Selecione o Extrato..."
170               Caminho = "C:\"
180               Caminho = LocalizarArquivo(Caminho, Titulo, filtro)
190               StrArquivo = Mid(Caminho, InStrRev(Caminho, "\") + 1)
200               Me.txtCaminho = Caminho
210               Me.txtArquivo = StrArquivo
                  '--------------------------------------
                  'Verifica se o extrato já foi importado
                  '--------------------------------------
220               If DCount("*", "tblMarcaDiaExtrato", "cpNomeArquivo = '" & Me.txtArquivo & "'") > 0 Then
230                    MsgBox "Este Extrato já foi importado!", vbCritical, "EXTRATO EXISTENTE"
                       '-------------------------------------
                       'Remove a ampulheta no cursor do mouse
                       '-------------------------------------
240                    Screen.MousePointer = 0
250                    Exit Sub
260               End If
                  '------------------------------------------------
                  'Variáveis para a importação do arquivo em excell
                  '------------------------------------------------
                  Dim N As Integer, oAppExcel As Object, Lista As String, uCell As Double, wbook As Object
                  '---------------------------------------------------------
                 'Variáveis que receberão a informação das células do Excell
                  '---------------------------------------------------------
                  Dim ID_Banco As Byte, dblCredito As Double, dblDebito As Double, StrHistorico As String, StrDoc As String
                  Dim nCount As Integer, dtData
                  '-----------------------
                  'Seto o objeto do Excell
                  '-----------------------
                  'Set oAppExcel = CreateObject("Excel.Application")
270               Set oAppExcel = GetObject(, "Excel.Application") ' Tentamos capturar o objeto.

280             If oAppExcel Is Nothing Then ' Se o objeto ainda não existir...
290                  Set oAppExcel = CreateObject("Excel.Application") ' ... mandamos criá-lo.
300             End If
310               oAppExcel.Workbooks.Open Caminho, , True
320               Set wbook = oAppExcel.Workbooks(StrArquivo)
330               oAppExcel.Workbooks.Open Me.txtCaminho
340               oAppExcel.Visible = False
350               oAppExcel.Worksheets("Sheet0").Activate
360               uCell = oAppExcel.Worksheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row ' uCell será o número da última célula não nula da coluna A

370               For N = 11 To uCell
                 ' MsgBox oAppExcel.ActiveSheet.Range("A" & N) & "- " & oAppExcel.ActiveSheet.Range("B" & N)
                      '-------------------------------------------------
                      'Verifico se a célula contém um campo do tipo Data
                      '-------------------------------------------------
380                   If IsDate(oAppExcel.ActiveSheet.Range("A" & N)) Then
                          '------------------------------------------------------------------
                          'Verifica o comprimento dos ranges Credito e Debito para em sendo 0
                          'remeterá para o rótulo continua
                          '------------------------------------------------------------------
390                       If Len("" & oAppExcel.ActiveSheet.Range("C" & N)) = 0 And Len("" & oAppExcel.ActiveSheet.Range("D" & N)) = 0 Then
400                           GoTo Pula
410                       End If
                          '---------------------------------------------------------------------------
                          'Verifico o comprimento do Range Credito na planilha, em sendo 0 é um débito
                          '---------------------------------------------------------------------------
420                       If Len("" & oAppExcel.ActiveSheet.Range("D" & N)) > 0 Then
                              '----------------------------------------------------------------------
                              'Aplica nas variáveis os respectivos valores condizentes com as células
                              '----------------------------------------------------------------------
430                           ID_Banco = Me.cboBanco.Column(0)
440                           dtData = oAppExcel.ActiveSheet.Range("A" & N)
450                           StrHistorico = oAppExcel.ActiveSheet.Range("B" & N)
460                           StrDoc = oAppExcel.ActiveSheet.Range("C" & N)
470                           dblCredito = oAppExcel.ActiveSheet.Range("D" & N)
480                           dblDebito = 0
                              '---------------------------
                              'Insere os valores na tabela
                              '---------------------------
490                           CurrentDb.Execute "INSERT INTO tblMovimento_Banco (idCaixa, Historico, DataMovimento, ValorCredito, ValorDebito, NumDoc, TipoDoc, cpTipoID)" _
                                              & "Values (""" & ID_Banco & """, """ & StrHistorico & """, """ & dtData & """, """ & dblCredito & """," _
                                              & """" & dblDebito & """, """ & StrDoc & """,'1', '1')"
500                       Else
                              '----------------------------------------------------------------------
                              'Aplica nas variáveis os respectivos valores condizentes com as células
                              '----------------------------------------------------------------------
510                           ID_Banco = Me.cboBanco.Column(0)
520                           dtData = oAppExcel.ActiveSheet.Range("A" & N)
530                           StrHistorico = oAppExcel.ActiveSheet.Range("B" & N)
540                           StrDoc = oAppExcel.ActiveSheet.Range("C" & N)
550                           dblCredito = 0
560                           dblDebito = Mid(oAppExcel.ActiveSheet.Range("E" & N), 2, Len(oAppExcel.ActiveSheet.Range("E" & N)))
                              '---------------------------
                              'Insere os valores na tabela
                              '---------------------------
570                           CurrentDb.Execute "INSERT INTO tblMovimento_Banco (idCaixa, Historico, DataMovimento, ValorCredito, ValorDebito, NumDoc, TipoDoc, cpTipoID)" _
                                              & "Values (""" & ID_Banco & """, """ & StrHistorico & """,""" & dtData & """, """ & dblCredito & """," _
                                              & """" & dblDebito & """, """ & StrDoc & """,'2', '1')"
580                       End If
590                   End If
                      '----------------------------------------------------------
                      'Incrementa o contador para verificar a última linha válida
                      '----------------------------------------------------------
600                   nCount = nCount + 1
      '-----------------------------------------------------------------------------------
      'Rótulo par aonde é direcionado o código caso os ranges Credito e Debito sejam nulos
      '-----------------------------------------------------------------------------------
Pula:
610               Next
                  '---------------------------------------------------------
                  'Adiciona na tabela o registro da última importação valida
                  '---------------------------------------------------------
620               CurrentDb.Execute "INSERT INTO tblMarcaDiaExtrato (Banco_ID, cpDataUltimaImportacao, cpDescricao, cpNumDoc, cpNomeArquivo) Values " _
                                  & " (""" & ID_Banco & """, #" & dtData & "#, """ & StrHistorico & """,""" & StrDoc & """, """ & Me.txtArquivo & """)"
                  '-------------------------------------
                  'Remove a ampulheta no cursor do mouse
                  '-------------------------------------
630               Screen.MousePointer = 0
                  '---------------------
                  'Mensagem de conclusão
                  '---------------------
640               MsgBox "Extrato importado com Sucesso!", vbInformation, "PRONTO"
                  '-----------------------------------------------
                  'Destiva a mensagem de aviso sobre  a importação
                  '-----------------------------------------------
650               Me.lbAviso.Visible = False
                  oAppExcel.Workbooks.Save Me.txtCaminho
                  '--------------------------------------------
                  'Termina a aplicação Excell e limpa ao objeto
                  '--------------------------------------------
660               oAppExcel.DisplayAlerts = False
680               Set oAppExcel = Nothing
690               Set wbook = Nothing
                  Rows = ""
'670               oAppExcel.Application.Quit
700               Call MatarProcesso("Excel.exe")
                  uCell = Empty
710               'DoCmd.Close acForm, "frmMovimentacaoBanco"
720              ' DoCmd.OpenForm "frmMovimentoBanco"

                  '---------------------------------------------------------------------------
                  'Carrego nas variáveis o caminho de origem do arquivo e o caminho do destino
                  '---------------------------------------------------------------------------
730               StrOrigem = Caminho
740               StrDestino = CurrentProject.Path & "\Extratos\" & txtArquivo
                  '----------------------------------------
                  'Copio o arquivo da origem para o destino
                  '----------------------------------------
                  'FileCopy StrOrigem, StrDestino
                  '-------------------------
                  'Apago o arquivo na origem
                  '-------------------------
                  'Kill StrOrigem
750           Case vbNo
760       End Select
      '---------------------------------------------------------
      'Atualiza o formulário para exibir os registros importados
      '---------------------------------------------------------
770   Me.AtualizaForm
780   Exit Sub
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      'Tratamento de Erros
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Exit_TrataErro:
790       DoCmd.Hourglass False
800       DoCmd.Echo True
810   Exit Sub
TrataErro:
820       Select Case err.Number
              Case 0, 20, 429
830             Resume Next
840           Case Else
850             DoCmd.Hourglass False
860             DoCmd.Echo True
               'Chama a função global de tratamento de erros
870            GlobalErrHandler (Me.Name)
880            Resume Exit_TrataErro
890       End Select
End Sub