Macro para importar vários arquivos .TXT

15 de outubro de 2013

Olá, peço ajuda para o seguinte problema:

Recebo frequentemente vários arquivos de texto com os mais variados nomes e preciso de uma macro para importa-los para uma planilha do Excel.

Estes arquivos sempre estão dentro de uma mesma pasta do Windows e eu precisaria que na coluna Z viesse o nome correspondente de cada arquivo importado.

Quando faço a importação manual, uso DELIMITADO > TABULAÇÃO

É possível isso?

zinhovba · 15 de outubro de 2013

Boa noite!!

Aqui tem muita coisa que lhe ajudara!!

http://www.cpearson.com/excel/ImportingFixedWidth.aspx

Não testado, tente adaptar

Sub test() 
    Dim myDir As String, fn As String, txt As String, a(), n As Long, i As Long, ff As Integer 
    myDir = "C:\test" '<- Mude de acordo com sua necessidade
    fn = Dir(myDir & "*.txt") 
    Do While fn <> "" 
        ff = FreeFile 
        Open myDir & "\" & fn For Input As #ff 
        Do While Not EOF(ff) 
            Line Input #ff, txt 
            n = n + 1 : Redim Preserve a(1 To n) 
            a(n) = Split(txt, vbTab) 
        Loop 
        Close #ff 
        fn = Dir() 
    Loop 
    With ThisWorkbook.Sheets(1).Range("a1") 
        For i = 1 To n 
            .Offset(i-1).Resize(,UBound(a(i))+1).Value = a(i) 
        Next 
    End With 
End Sub

Outro..

Option Explicit 

Sub ImportarZinho() 

    Dim nxt_row As Long 

     'Caminho
    Const strPath As String = "T:\Log\" 
    Dim strExtension As String 


    Application.ScreenUpdating = False 

    ChDir strPath 

     'extensão
    strExtension = Dir(strPath & "*.txt") 

    Do While strExtension <> "" 

         'Adiciona o nome do arquivo na próxima linha
        Range("A65536").End(xlUp).Offset(1, 0).Value = strExtension 

        nxt_row = Range("A65536").End(xlUp).Offset(1, 0).Row 

        With ActiveSheet.QueryTables.Add(Connection:= _ 
            "TEXT;" & strPath & strExtension, Destination:=Range("$A$" & nxt_row)) 
            .Name = strExtension 
            .FieldNames = True 
            .RowNumbers = False 
            .FillAdjacentFormulas = False 
            .PreserveFormatting = True 
            .RefreshOnFileOpen = False 
            .RefreshStyle = xlInsertDeleteCells 
            .SavePassword = False 
            .SaveData = True 
            .AdjustColumnWidth = True 
            .RefreshPeriod = 0 
            .TextFilePromptOnRefresh = False 
            .TextFilePlatform = 850 
            .TextFileStartRow = 1 
            .TextFileOtherDelimiter = ":" 
            .TextFileTrailingMinusNumbers = True 
            .Refresh BackgroundQuery:=False 
        End With 

        strExtension = Dir 
    Loop 

    Application.ScreenUpdating = True 

End Sub

Sub test() 
    Dim myDir As String, fn As String, n As Long, t As Long 
    Dim dic As Object, e, x, y 
    Set dic = CreateObject("Scripting.Dictionary") 
    dic.CompareMode = 1 
    With Application.FileDialog(msoFileDialogFolderPicker) 
        If .Show Then myDir = .SelectedItems(1) & "\" 
    End With 
    If myDir = "" Then Exit Sub 
    fn = Dir(myDir & "*.txt") 
    Do While fn <> "" 
        If FileLen(myDir & fn) Then 
            n = n + 1 
            x = Split(CreateObject("Scripting.FileSystemObject") _ 
            .OpenTextFile(myDir & fn).ReadAll, vbCrLf) 
            For Each e In x 
                If e Like "*:*" Then 
                    y = Split(e, ":") 
                    If Not dic.exists(Trim$(y(0))) Then 
                        t = t + 1: dic(Trim$(y(0))) = t 
                        Cells(1, t + 2).Value = Trim(y(0)) 
                    End If 
                    Cells(n + 1, 1).Value = fn 
                    Cells(n + 1, dic(Trim$(y(0))) + 2).Value _ 
                    = Trim$(y(1)) 
                Else 
                    Cells(n + 1, 2).Value = e 
                End If 
            Next 
        End If 
        fn = Dir 
    Loop 
End Sub