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

    Importar do Ms Excel e atualizar tabela

    Silvio
    Silvio
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 4634
    Registrado : 20/04/2011

    Importar do Ms Excel e atualizar tabela Empty Importar do Ms Excel e atualizar tabela

    Mensagem  Silvio em 31/5/2016, 18:37

    Segue uma rotina que acabei de fazer que faz a importação de uma planilha do Ms Excel para uma tabela do Ms Acess.

    Não será preciso dizer que os campos da tabela e da planilha tem que serem iguais.

    Será preciso criar uma tabela temporária em teu sistema para receber os dados da planilha.

    Criar um botão de comando em um formulário e inserir o seguinte código.

    Código:
    'Desenvolvido por Silvio.
    '31/05/2017
    ' Requer referencia a Microsoft Office 11 Object Library
       On Error GoTo PROC_ERR
      
       Dim fd As FileDialog
       Set fd = Application.FileDialog(msoFileDialogFilePicker)
      
       fd.Title = "selecione o arquivo"
       fd.Filters.Add "Arquivo XLS", "*.xls", 1  'se for o caso, mude a extensão para XLSX, onde estão xls

       fd.Show
      
       If (fd.SelectedItems.Count > 0) Then
           '------inicio importação excel para sincronização
           Dim strPathFile As String, strFile As String, strPath As String
           Dim strTable As String
           Dim blnHasFieldNames As Boolean
           blnHasFieldNames = True
           strPathFile = fd.SelectedItems(1)
           strTable = "TblPrepostoTmp" 'planilha temporária que vai receber os dados do MS Excel.[/color]
          
           'apaga temporários, não é necessário, mas por segurança estou limpando a tabela antes
           DoCmd.RunSQL "Delete * from TblPrepostoTmp"
          
           'importa para tabela local temporária
           DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, blnHasFieldNames
           MsgBox "Registros importados com sucesso !" & vbCrLf & _
                 "Atualizando registros de comissão", vbInformation, Me.Caption
                  
                  
            'Declaração das Variaveis
    Dim DB As Database
    Dim rs As DAO.Recordset ' TblPrepostoTmp - onde estão os dados que serão importados
    Dim rs1 As DAO.Recordset ' tblacertocomissao -  para onde irão os dados a serem importados.


    Set DB = CurrentDb()


       'Filtra os dados da tabela de Origem e Define a tabela de Destino dos dados.
       Set rs = DB.OpenRecordset("SELECT * FROM TblPrepostoTmp ")
       Set rs1 = DB.OpenRecordset("tblacertocomissao")


    'Inicia a Gravação dos dados na Tabela de Destino (Dim rs1 As DAO.Recordset ' tblacertocomissao ) ,repete até COPIAR todos os Registros que foram selecionados
    Do While Not rs.EOF
           'Inicia a Gravação dos dados na tblacertocomissao
           rs1.AddNew
           rs1("CodPed") = rs("CodPed")
           rs1("DataPed") = rs("DataPed")
           rs1("NossoPedido") = rs("NossoPedido") & " / " & rs("VendedorOculta")
           rs1("VendedorOculta") = rs("VendedorOculta")
           rs1("Cliente") = rs("Cliente")
           rs1("PrazoOculta") = rs("PrazoOculta")
           rs1("ValortotalPedido") = rs("ValortotalPedido")
           rs1("ForneOculta") = rs("ForneOculta")
           rs1("Efetivado") = rs("Efetivado")
           rs1.Update
       rs.MoveNext
       Loop

       'Ao Final Encerra as Conexões
       rs.Close
       rs1.Close
       DB.Close
          
           MsgBox "Operação concluída.", vbInformation, Me.Caption
          
           'apaga temporarios da tblprepostotmp que recebeu a importação.
           DoCmd.RunSQL "Delete * from TblPrepostoTmp"
          
       Else
           MsgBox "Não foi escolhido nenhum arquivo", vbInformation, Me.Caption

       End If
      
    PROC_EXIT:
       Exit Sub
      
    PROC_ERR:
       DoCmd.Hourglass False
       If Err.Number = 3011 Then
          LocalXML = ""
          MsgBox ("Arquivo inválido.")
       Else
           MsgBox Err.Description
       End If
       Resume PROC_EXIT




    Bom proveito a todos, que tem essa dificuldade.

    Abraços.


    Última edição por Silvio em 31/5/2016, 22:54, editado 2 vez(es) (Razão : adição de explicação)
    pcnet
    pcnet
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 303
    Registrado : 16/12/2015

    Importar do Ms Excel e atualizar tabela Empty Re: Importar do Ms Excel e atualizar tabela

    Mensagem  pcnet em 31/5/2016, 19:35

    Obrigado pela partilha mestre Silvio! Very Happy
    É sempre bom ter à mão um exemplo destes.
    Cumprimentos

      Data/hora atual: 25/11/2020, 13:28