[Resolvido]Importação Seletiva

Bom dia amigos,
Tenho uma planilha gigantesca no Excel e gostaria de importar somente algumas colunas para o Access via VBA,
Poderiam me ajudar?

Bom dia !

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

No aguardo.

VBA

Por gentileza, poste o exemplo do seu Banco de Dados.

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

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 !!!

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.

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.

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