MaximoAccess

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

Obrigado

Administração do MaximoAccess

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

    [Resolvido]Importação Seletiva

    Compartilhe
    avatar
    gabrielpn06
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 175
    Registrado : 17/01/2017

    [Resolvido]Importação Seletiva

    Mensagem  gabrielpn06 em 22/11/2017, 13:34

    Bom dia amigos,
    Tenho uma planilha gigantesca no Excel e gostaria de importar somente algumas colunas para o Access via VBA,
    Poderiam me ajudar?
    avatar
    kleber.arruda
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 53
    Registrado : 22/09/2016

    Importação Seletiva

    Mensagem  kleber.arruda em 22/11/2017, 13:53


    Bom dia !

    A importação será em VBA ou utilizando as ferramentas nativas do Access?

    No aguardo.
    avatar
    gabrielpn06
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 175
    Registrado : 17/01/2017

    Re: [Resolvido]Importação Seletiva

    Mensagem  gabrielpn06 em 22/11/2017, 14:03

    VBA
    avatar
    kleber.arruda
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 53
    Registrado : 22/09/2016

    Importação Seletiva

    Mensagem  kleber.arruda em 22/11/2017, 14:06


    Por gentileza, poste o exemplo do seu Banco de Dados.
    avatar
    gabrielpn06
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 175
    Registrado : 17/01/2017

    Re: [Resolvido]Importação Seletiva

    Mensagem  gabrielpn06 em 22/11/2017, 14:12

    Boa tarde kleber,
    Meu app está bem complexo, para postar aqui, teria que retirar muita coisa.

    A ideia é determinar no código de importação, 3 colunas de uma tabela de excel que possui 300 colunas
    avatar
    kleber.arruda
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 53
    Registrado : 22/09/2016

    Importação Seletiva

    Mensagem  kleber.arruda em 22/11/2017, 14:19

    Tranquilo, então vamos lá:

    1º Passo

    Crie um módulo e adicione o seguinte código

    Código:
    Public blnSair As Boolean

    Type tagOPENFILENAME
       lStructSize As Long
       hwndOwner As Long
       hInstance As Long
       strFilter As String
       strCustomFilter As String
       nMaxCustFilter As Long
       nFilterIndex As Long
       strFile As String
       nMaxFile As Long
       strFileTitle As String
       nMaxFileTitle As Long
       strInitialDir As String
       strTitle As String
       Flags As Long
       nFileOffset As Double
       nFileExtension As Double
       strDefExt As String
       lCustData As Long
       lpfnHook As Long
       lpTemplateName As String
       
    End Type

    Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
       Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean

    Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
       Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean

    Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

    Global Const ahtOFN_READONLY = &H1

    Global Const ahtOFN_OVERWRITEPROMPT = &H2

    Global Const ahtOFN_HIDEREADONLY = &H4

    Global Const ahtOFN_NOCHANGEDIR = &H8

    Global Const ahtOFN_SHOWHELP = &H10

    Global Const ahtOFN_NOVALIDATE = &H100

    Global Const ahtOFN_ALLOWMULTISELECT = &H200

    Global Const ahtOFN_EXTENSIONDIFFERENT = &H400

    Global Const ahtOFN_PATHMUSTEXIST = &H800

    Global Const ahtOFN_FILEMUSTEXIST = &H1000

    Global Const ahtOFN_CREATEPROMPT = &H2000

    Global Const ahtOFN_SHAREAWARE = &H4000

    Global Const ahtOFN_NOREADONLYRETURN = &H8000

    Global Const ahtOFN_NOTESTFILECREATE = &H10000

    Global Const ahtOFN_NONETWORKBUTTON = &H20000

    Global Const ahtOFN_NOLONGNAMES = &H40000

    Global Const ahtOFN_EXPLORER = &H80000

    Global Const ahtOFN_NODEREFERENCELINKS = &H100000

    Global Const ahtOFN_LONGNAMES = &H200000

    Function getOpenFile(Optional varDirectory As Variant, _
       Optional varTitleForDialog As Variant) As Variant

       Dim strFilter                               As String
       Dim lngFlags                                As Long
       Dim varFileName                             As Variant

       lngFlags = ahtOFN_FILEMUSTEXIST Or _
                   ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
                   
       If IsMissing(varDirectory) Then
       
           varDirectory = ""
           
       End If
       
       If IsMissing(varTitleForDialog) Then
       
           varTitleForDialog = ""
           
       End If

       strFilter = ahtAddFilterItem(strFilter, _
                   "Arquivos Microsoft Excel (*.XLS)", "*.csv")

       varFileName = ahtCommonFileOpenSave( _
                       OpenFile:=True, _
                       InitialDir:=varDirectory, _
                       Filter:=strFilter, _
                       Flags:=lngFlags, _
                       DialogTitle:=varTitleForDialog)

       If Not IsNull(varFileName) Then
       
           varFileName = TrimNull(varFileName)
           
       End If
       
       getOpenFile = varFileName
       
    End Function

    Function ahtCommonFileOpenSave( _
               Optional ByRef Flags As Variant, _
               Optional ByVal InitialDir As Variant, _
               Optional ByVal Filter As Variant, _
               Optional ByVal FilterIndex As Variant, _
               Optional ByVal DefaultExt As Variant, _
               Optional ByVal Filename As Variant, _
               Optional ByVal DialogTitle As Variant, _
               Optional ByVal hwnd As Variant, _
               Optional ByVal OpenFile As Variant) As Variant

       Dim OFN                                 As tagOPENFILENAME
       Dim strFileName                         As String
       Dim strFileTitle                        As String
       Dim fResult                             As Boolean

       If IsMissing(InitialDir) Then InitialDir = ""
       If IsMissing(Filter) Then Filter = ""
       If IsMissing(FilterIndex) Then FilterIndex = 1
       If IsMissing(Flags) Then Flags = 0&
       If IsMissing(DefaultExt) Then DefaultExt = "txt"
       If IsMissing(Filename) Then Filename = ""
       If IsMissing(DialogTitle) Then DialogTitle = ""
       If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
       If IsMissing(OpenFile) Then OpenFile = True

       strFileName = Left(Filename & String(256, 0), 256)
       strFileTitle = String(256, 0)
       
       

       With OFN
           .lStructSize = Len(OFN)
           .hwndOwner = hwnd
           .strFilter = Filter
           .nFilterIndex = FilterIndex
           .strFile = strFileName
           .nMaxFile = Len(strFileName)
           .strFileTitle = strFileTitle
           .nMaxFileTitle = Len(strFileTitle)
           .strTitle = DialogTitle
           .Flags = Flags
           .strDefExt = DefaultExt
           .strInitialDir = InitialDir
           .hInstance = 0
           .strCustomFilter = ""
           .nMaxCustFilter = 0
           .lpfnHook = 0
           'New for NT 4.0
           .strCustomFilter = String(255, 0)
           .nMaxCustFilter = 255
           
       End With
       

       If OpenFile Then
       
           fResult = aht_apiGetOpenFileName(OFN)
           
       Else
       
           fResult = aht_apiGetSaveFileName(OFN)
           
       End If


       If fResult Then

           If Not IsMissing(Flags) Then
           
               Flags = OFN.Flags
               ahtCommonFileOpenSave = TrimNull(OFN.strFile)
               
           Else
               ahtCommonFileOpenSave = "" 'alterado por JR.
               
           End If
           
       End If
       
    End Function

    Function ahtAddFilterItem(strFilter As String, _
                             strDescription As String, Optional _
                             VarItem As Variant) As String
       
       If IsMissing(VarItem) Then VarItem = "*.*"
       ahtAddFilterItem = strFilter & _
                   strDescription & vbNullChar & _
                   VarItem & vbNullChar
    End Function


    Private Function TrimNull(ByVal strItem As String) As String

       Dim intPos                              As Double
       
       intPos = InStr(strItem, vbNullChar)
       
       If intPos > 0 Then
       
           TrimNull = Left(strItem, intPos - 1)
           
       Else
       
           TrimNull = strItem
           
       End If
       
    End Function

    Function AbreCaixaDialogo() As String

       Dim strFilter                           As String
       Dim strCurDir                           As String
       
       'para utilizar defina o filtro tipo de arquivo conforme abaixo
       '   TipoArquivo = "*_re.txt"
       '   strFilter = ahtAddFilterItem(strFilter, "Arquivos de Registro de Exportação (*_re.txt)", TipoArquivo)
       '  ou
       
       strFilter = ahtAddFilterItem(strFilter, "")
       
       'Para Utilizar:
       
       AbreCaixaDialogo = ahtCommonFileOpenSave(, strCurDir, strFilter, , , _
                          , "Selecione o arquivo desejado", , True)
       
    End Function


    2º Passo


    No formulário que será utilizado para realizar a importação, adapte o seguinte código:

    Código:
    '---------------------------------------------------------------------------------------------------------
    '  Autor: Kleberson França
    '
    '  Data: 22/11/2017
    '
    '  Rotina de Importação de Dados Excel
    '---------------------------------------------------------------------------------------------------------

    Private Sub Bt_Form007_001_Atualizar_Dados_Click()

       Dim DB                                  As DAO.Database
       Dim SQL                                 As String
       Dim RS                                  As DAO.Recordset
       Dim resp
       Dim NOME_ARQUIVO
       Dim strCurDir
       Dim FormatoArquivo
       Dim Extensao
       
       Set DB = CurrentDb
       
    On Error GoTo TRATA_ERRO
       
    '---------------------------------------------------------------------------------------------------------
    ' 1. Importar Dados Atualizados
    '---------------------------------------------------------------------------------------------------------

           resp = MsgBox("Deseja Importar Dados ?", vbYesNo, "Meu Projeto")
               
           If resp = vbNo Then
           
               Exit Sub
               
           End If
           
    '---------------------------------------------------------------------------------------------------------
    ' 2.1 Muda cursor para ampulheta
    '---------------------------------------------------------------------------------------------------------
       
       Screen.MousePointer = 11
       
    '---------------------------------------------------------------------------------------------------------
    ' 3. A rotina é executada
    '---------------------------------------------------------------------------------------------------------

    '---------------------------------------------------------------------------------------------------------
    ' 3.1 Limpa a Tabela repositória
    '---------------------------------------------------------------------------------------------------------
       
       Call DeleteTabelaRepositoria

    '---------------------------------------------------------------------------------------------------------
    ' 3.2 Insere os Registros de Importação na Tabela Layout_Cad_Item_Compra
    '---------------------------------------------------------------------------------------------------------
     
       NOME_ARQUIVO = ahtCommonFileOpenSave(, strCurDir, _
                                            "Pasta de Trabalho do Excel", _
                                            FormatoArquivo, _
                                            Extensao, , _
                                            "Selecione o Arquivo para Importacao", , False)
                                                               
       If NOME_ARQUIVO = "" Then
           
           Screen.MousePointer = 0
       
           Set DB = Nothing
                           
           Exit Sub
                           
           Else
             
               DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, _
               "MinhaTabela", NOME_ARQUIVO, True
       
       End If
       
    '---------------------------------------------------------------------------------------------------------
    ' 4. Muda cursor para seta
    '---------------------------------------------------------------------------------------------------------
       
       Screen.MousePointer = 0

    '---------------------------------------------------------------------------------------------------------
    ' 5. Finalização da Rotina
    '---------------------------------------------------------------------------------------------------------
           
       MsgBox ("Dados atualizados com sucesso !"), vbInformation, "MeuProjeto"
       
       Exit Sub
       
    '---------------------------------------------------------------------------------------------------------
    ' 6. Finaliza a aplicação, caso haja algum erro.
    '---------------------------------------------------------------------------------------------------------
       
    TRATA_ERRO:

       Screen.MousePointer = 0
       
       RS.Close
       
       Set RS = Nothing
       
       Set DB = Nothing

       Call Msgbox_Trata_Erro

       Exit Sub

    End Sub

    '------------------------------------------------------------------------------------------------------------------------------------------
    ' Procedimento DELETE Layout_Cad_Item_Compra
    '------------------------------------------------------------------------------------------------------------------------------------------

    Private Sub DeleteTabelaRepositoria()

       Dim DB                                  As DAO.Database
       Dim SQL                                 As String
       
       Set DB = CurrentDb
       
       SQL = "DELETE FROM MinhaTabela"

       DB.Execute (SQL)
       
       DB.Close
       
    End Sub


    Fico no aguardo.

    Caso dê certo, não esquece de dar como Resolvido !!!

    Enjoy !!!
    avatar
    gabrielpn06
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 175
    Registrado : 17/01/2017

    Re: [Resolvido]Importação Seletiva

    Mensagem  gabrielpn06 em 22/11/2017, 19:24

    Boa tarde, desculpe a demora.


    Lendo o código não consegui identificar em qual parte determino as colunas que desejo importar, sou novo no Access e peço desculpas se não consegui interpretar o óbvio.
    avatar
    kleber.arruda
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 53
    Registrado : 22/09/2016

    Importação Seletiva

    Mensagem  kleber.arruda em 23/11/2017, 11:00


    Bom dia !

    Na importação via VBA do Access, caso o número de campos da Tabela não seja iguais ao do Excel, o Access importará somente os campos em comum.

    Tente e me retorne.
    avatar
    gabrielpn06
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 175
    Registrado : 17/01/2017

    Re: [Resolvido]Importação Seletiva

    Mensagem  gabrielpn06 em 28/11/2017, 13:50

    Bom dia! desculpe a demora.
    Funcionou muito obrigado pela ajuda!

      Data/hora atual: 22/10/2018, 22:14