Notifications
Clear all

Importar vários TXT's com delimitador

5 Posts
2 Usuários
0 Reactions
786 Visualizações
(@odilon)
Posts: 2
New Member
Topic starter
 

Bom dia pessoal,

Estou com a seguinte situação:

Tenho muitos txt's exportados através de LOGs de LOGON.
Atualmente tenho que importar todos manualmente, 1 por 1. para poder criar uma base de dados.
Os dados contidos nestes txt's são delimitados por | (BARRA VERTICAL).

Será que há uma maneira onde através de um loop arquivo por arquivo fosse importado delimitadamente em uma planilha?

 
Postado : 07/02/2013 10:17 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tard!!

Tlavez eu não possa ajuda-lo mas...
Tente ver uma adaptação...

Option Explicit
 
Sub Test()
     
    Dim fs, filepath As Variant
    Dim i As Long
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
     'Altere o caminho a seguir para apontar para onde seus arquivos são armazenados.
    filepath = "C:TEST"
     
     'Isto irá procurar todos os arquivos dentro da pasta
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .Filename = "*.txt"
        .SearchSubFolders = True 'comentar esta linha se os arquivos não são armazenados em subpastas
        .LookIn = filepath
        If .Execute > 0 Then
             
             'Para cada arquivo que ele encontra ...
            For i = 1 To .FoundFiles.Count
                 '...abra o...
                Workbooks.Open (.FoundFiles(i))
                 'Quebrar Coluna A em delimitado por colunas,
                Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
                TrailingMinusNumbers:=True
                 'e movê-lo para este livro!
                ActiveSheet.Move After:=ThisWorkbook.Sheets(1)
            Next i
        Else
            MsgBox "Arquivos não encontrados."
        End If
    End With
     
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Sub OutraFonte() 
    ActiveSheet.Paste 
    Selection.TextToColumns Destination:=Range(ActiveCell, ActiveCell), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ 
    :=Array(1, 2), TrailingMinusNumbers:=True      
End Sub 

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 07/02/2013 11:16 am
(@odilon)
Posts: 2
New Member
Topic starter
 

Alexandre,

Fiz uma modificação e ficou assim:

Sub Test()
     
    Dim fs, filepath As Variant
    Dim i As Long
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
     'Altere o caminho a seguir para apontar para onde seus arquivos são armazenados.
    filepath = "C:UsersOdilon.JunirDesktopINVENTÁRIOtxt"
     
     'Isto irá procurar todos os arquivos dentro da pasta
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .Filename = "*.txt"
        .SearchSubFolders = True 'comentar esta linha se os arquivos não são armazenados em subpastas
        .LookIn = filepath
        If .Execute > 0 Then
             
             'Para cada arquivo que ele encontra ...
            For i = 1 To .FoundFiles.Count
                 '...abra o...
                Workbooks.Open (.FoundFiles(i))
                 'Quebrar Coluna A em delimitado por colunas,
                Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
                TrailingMinusNumbers:=True
                 'e movê-lo para este livro!
                ActiveSheet.Move After:=ThisWorkbook.Sheets(1)
            Next i
        Else
            MsgBox "Arquivos não encontrados."
        End If
    End With
     
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

As modificações foram feitas colocando o parâmetro "Other" como true, e adicionado outro parâmetro "OtherChar" com o caractere que eu quero delimitar, e lógico retirando o TRUE do "COMMA", mas o erro ocorre na linha "Set fs = Application.FileSearch", ERRO: "Erro em tempo de execução '445': O obejto não aceita esta ação", tem ideia do que possa ser?

 
Postado : 07/02/2013 1:33 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Só para contribuir, application.filesearch foi descontinuada à partir do excel 2007, funciona somente até o 2003; 2007 e acima pode ser utilizado o Dir

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 07/02/2013 1:37 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Esqueci segue um exemplo da utilização do comando dir

ChDir sPath 'posiciona-se no diretório desejado
sDir = Dir("*.xls?")
Do While sDir <> "" 'Executa até não encontrar arquivo
           If sDir <> OldName Then 'aqui se quiser omitir algum arquivo
              Application.DisplayAlerts = False
              Application.ScreenUpdating = False
              Workbooks.Open Filename:=sDir, UpdateLinks:=0
.... 'aqui o que deseja fazer
            Workbooks(sDir).Close SaveChanges:=False 'fecha o arquivo
            sDir = Dir 'se posiciona no proximo
            Else
            Exit Sub 
            End If

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 07/02/2013 1:52 pm