Tomás Vásquez Fórum

Código: Selecionar todos

Sub ImportarArq()
Dim cn                  As Object
Dim Fd                  As Office.FileDialog
Dim rsTAB               As Recordset
Dim rs                  As Object
Dim Ws                  As String
Dim query               As String
Dim nTab                As Variant
Dim SelectFile          As Variant
Dim i                   As Long
Dim Caminho             As String

Set Fd = Application.FileDialog(msoFileDialogFilePicker)
With Fd
    .AllowMultiSelect = True
    .Title = "Please select the file" '
    .InitialFileName = "C:\Users\" & Environ("Username")
    '.InitialFileName = ThisWorkbook.Path & "\Arquivos" 
    .Filters.Clear
    .Filters.Add "Excel", "*.xls*"
    .Filters.Add "All Files", "*.*"
        If .Show = True Then
            'Instancia e configura o objeto cn.
            Set cn = New ADODB.Connection
           
            ' Incia um laço entre todos os arquivos selecionados.
            For i = 1 To .SelectedItems.Count
                Caminho = .SelectedItems(i)
               
                ' Abre a conexão com o Arquivo.
                With cn
                    .Provider = "Microsoft.ACE.OLEDB.12.0"
                    .Properties("Extended Properties").Value = "Excel 8.0"
                    .Open Caminho
                End With
               
                ' Instancia o Schema das Tabelas.
                Set rsTAB = cn.OpenSchema(adSchemaTables)

                ' Inicia novo laço entre as tabelas existentes no arquivo.
                Do While Not rsTAB.EOF
                    nTab = rsTAB!TABLE_NAME
                    If Not (nTab Like "MSys*" Or nTab Like "~*" Or nTab Like "sys*") Then
                        Let Ws = nTab
                        Exit Do
                    End If
                    rsTAB.MoveNext
                Loop
               
                ' Atribui comando de consulta na variável Query.
                Let query = "SELECT * FROM [" & Ws & "]"
                ' Intancia um RecordSet
                Set rs = New ADODB.Recordset
                ' Executa a consulta, envia para planilha e fecha o objeto.
                rs.Open query, cn
                Planilha6.Range("A" & Application.WorksheetFunction.CountA(Planilha6.Columns(1)) + 1).CopyFromRecordset rs
                rs.Close
                ' Fecha conexão do Objeto cn.
                cn.Close
            Next i
        Else
            Exit Sub
        End If
    End With
    ' Limpa instância do Objeto cn.
    Set cn = Nothing
End Sub