Visual Basic Alterar importação txt de um arquivo para vários com mesmo formato

[aprendiz_vba]

Boa tarde!

 

Sou aprendiz no VBA, estou com uma demanda que meu conhecimento técnico não permite seguir.

Adaptei para minha realidade um código publicado na internet para importação de txt, vide código adaptado abaixo.

Agora precisava adaptá-lo novamente para importar vários arquivos, neste mesmo layout, de uma única vez, estarão todos no mesmo diretório.

Alguém conseguiria me ajudar, por favor.

Public Sub Importar()
    Dim Ficheiro As String
    Ficheiro = "C:\Users\mor\OneDrive\Área de Trabalho\eb_082019_fil01.txt"
    
    Dim rg As Range
    Set rg = Range("A1")
    
    Open Ficheiro For Input As #1
    
    Dim S As String
    Do Until EOF(1)
        Line Input #1, S
        
        rg = Val(Left(S, 10))
        rg.Offset(0, 0) = Mid(S, 1, 1)
        rg.Offset(0, 3) = Mid(S, 6, 8)
        rg.Offset(0, 1) = Mid(S, 21, 7)
        rg.Offset(0, 2) = Mid(S, 349, 45)
        rg.Offset(0, 4) = Ficheiro
        
        Set rg = rg.Offset(1, 0)
    Loop
    
    Close #1
    
    Call Remove_Linhas
    Call Ajusta_Valor
        
    Cells.Select
    Selection.Columns.AutoFit
           
End Sub

 

[Basole]

@aprendiz_vba segue as com as alteracoes solicitadas

 

Public Sub Importar()
    Dim Ficheiro As String
    Dim fd As FileDialog
    Dim strPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim i As Long
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.AllowMultiSelect = False
    fd.Title = "Selecione a Pasta que contem o arquivos TXT"
    If fd.Show = -1 Then
        strPath = fd.SelectedItems(1)
    End If
    
    If strPath = "" Then Exit Sub
    
    If VBA.Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    xFile = VBA.Dir(strPath & "*.txt")
    
    If xFile = "" Then
        MsgBox "Nenhum arquivo encontrado !", 64, "Atencao"
        Exit Sub
    End If
    
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = VBA.Dir()
    Loop
        
    If xFiles.Count > 0 Then
        
    For i = 1 To xFiles.Count
        
    Ficheiro = strPath & xFiles.Item(i)
    
    Dim rg As Range
    Set rg = Range("A1")
    
    Open Ficheiro For Input As #1
    
    Dim S As String
    Do Until EOF(1)
        Line Input #1, S
        
        rg = Val(Left(S, 10))
        rg.Offset(0, 0) = Mid(S, 1, 1)
        rg.Offset(0, 3) = Mid(S, 6, 8)
        rg.Offset(0, 1) = Mid(S, 21, 7)
        rg.Offset(0, 2) = Mid(S, 349, 45)
        rg.Offset(0, 4) = Ficheiro
        
        Set rg = rg.Offset(1, 0)
    Loop
    
    Close #1
    
    i = i + 1
    
    Next
    
    Call Remove_Linhas
    Call Ajusta_Valor
   
   End If
    
    Cells.Select
    Selection.Columns.AutoFit
           
End Sub

 

[aprendiz_vba]

Basole, boa noite!

 

Gratidão pela ajuda.

Importou apenas um arquivo, conseguiria me ajudar novamente, por favor.

adicionado 47 minutos depois

@Basole

Boa noite!

 

Gratidão pela ajuda.

Importou apenas um arquivo, conseguiria me ajudar novamente, por favor.

[Basole]

@aprendiz_vba eu suponho que, um arquivo txt esteja sobrepondo outro na importacao.

 

Segue alteracoes:

 

Public Sub Importar()
    Dim Ficheiro As String
    Dim fd As FileDialog
    Dim strPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim i As Long
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.AllowMultiSelect = False
    fd.Title = "Selecione a Pasta que contem o arquivos TXT"
    If fd.Show = -1 Then
        strPath = fd.SelectedItems(1)
    End If
    
    If strPath = "" Then Exit Sub
    
    If VBA.Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    xFile = VBA.Dir(strPath & "*.txt")
    
    If xFile = "" Then
        MsgBox "Nenhum arquivo encontrado !", 64, "Atencao"
        Exit Sub
    End If
    
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = VBA.Dir()
    Loop
        
    If xFiles.Count > 0 Then
        
    For i = 1 To xFiles.Count
        
    Ficheiro = strPath & xFiles.Item(i)
    
    Dim rg As Range
    Dim lr As Long
    
    With ActiveSheet
    lr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row
    Set rg = .Range("A" & lr)
    End With
    
    Open Ficheiro For Input As #1
    
    Dim S As String
    Do Until EOF(1)
        Line Input #1, S
        
        rg = Val(Left(S, 10))
        rg.Offset(0, 0) = Mid(S, 1, 1)
        rg.Offset(0, 3) = Mid(S, 6, 8)
        rg.Offset(0, 1) = Mid(S, 21, 7)
        rg.Offset(0, 2) = Mid(S, 349, 45)
        rg.Offset(0, 4) = Ficheiro
        
        Set rg = rg.Offset(1, 0)
    Loop
    
    Close #1
    
    i = i + 1
    
    Next
    
     Call Remove_Linhas
    Call Ajusta_Valor
   
   End If
    
    Cells.Select
    Selection.Columns.AutoFit
           
End Sub

 

[aprendiz_vba]

@Basole Só um deles novamente.

Este chama outros duas Sub, pode ser elas?

Desde já peço desculpas pela amolação.

Sub Remove_Linhas()
  Dim lLin As Long

  Application.ScreenUpdating = False


  With Sheets("Planilha1")
  For lLin = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
  If .Cells(lLin, "A") <> 5 Then
  .Rows(lLin).Delete
  End If

  If lLin Mod 100 = 0 Then DoEvents
  Next lLin
  End With
  Application.ScreenUpdating = True
End Sub

Sub Ajusta_Valor()
  Dim lLin As Long
  
  Application.ScreenUpdating = False


  With Sheets("Planilha1")
  For lLin = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
  If .Cells(lLin, "A") = 5 Then
  .Cells(lLin, "A").Offset(0, 3) = .Cells(lLin, "A").Offset(0, 3) / 100 'ajusta valor
  End If

  If lLin Mod 100 = 0 Then DoEvents
  Next lLin
  End With
  Application.ScreenUpdating = True
  
   Columns("D:D").Select
   Selection.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"

End Sub

 

[Basole]

@aprendiz_vba seria bom ao invés de eu ficar supondo, voce anexar os exemplos de arquivos txt que serao importados

[aprendiz_vba]

@Basole Boa noite!

Segue modelo de arquivos.

Agradeço mais uma vez

Arquivo1.txt Arquivo2.txt

[Basole]

Esses seus codigos estão muito confusos. 

Por favor, envie um arquivo do Excel com esses dados importados manualmente, demostrando o resultado esperado.

 

[aprendiz_vba]

@Basole Conforme solicitado, segue o resultado do Arquivo1.

Agradeço mais uma vez por toda a paciência e ajuda.

Exemplo.xlsx

[aprendiz_vba]

@Basole Oi. Boa noite!

Consegui me ajudar com está importação?

 

[Basole]

@aprendiz_vba fiz os ajustes no seu codigo, veja se é isso: 

 

         

Public Sub Importar()
    Dim Ficheiro As String
    Dim fd As FileDialog
    Dim strPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim i As Long
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    fd.AllowMultiSelect = False
    fd.Title = "Selecione a Pasta que contem o arquivos TXT"
    
    If fd.Show = -1 Then
        strPath = fd.SelectedItems(1)
    End If
    
    If strPath = "" Then Exit Sub
    
    If VBA.Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    xFile = VBA.Dir(strPath & "*.txt")
    
    If xFile = "" Then
        MsgBox "Nenhum arquivo encontrado !", 64, "Atencao"
        Exit Sub
    End If
    
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = VBA.Dir()
    Loop
        
    If xFiles.Count > 0 Then
          
    For i = 1 To xFiles.Count
        
    Ficheiro = strPath & xFiles.Item(i)
    
    Dim LR As Long
    Dim c As Long
    Dim sColName As String: sColName = "COL "
    
    With ThisWorkbook.ActiveSheet
    
     ' Adiciona nomes nas colunas
    For c = 1 To 5
    .Cells(1, c).Value = sColName & c
    .Cells(1, c).Font.Bold = True
    .Cells(1, c).HorizontalAlignment = xlCenter
    Next c
    
    LR = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
        
    Open Ficheiro For Input As #1
    
    Dim S As String
    Do Until EOF(1)
    
        Line Input #1, S
        
       
        'FILIAL:
       If VBA.InStr(S, "abcdef") = 26 Then
        .Cells(LR, "e").NumberFormat = "@"
        .Cells(LR, "e") = VBA.Mid(S, 10, 4)
        End If
                
        'DADOS:
        If VBA.InStr(S, "5000") = 1 Then
        
            .Cells(LR, "A").Value = VBA.Mid(S, 1, 1)
            .Cells(LR, "B").Value = VBA.Mid(S, 21, 7)
            .Cells(LR, "C").Value = VBA.Mid(S, 349, 45)
            .Cells(LR, "D").NumberFormat = "#,##0.00"
            .Cells(LR, "D").Value = VBA.Mid(S, 6, 5)
         
         LR = .Cells(.Rows.Count, "a").End(xlUp).Offset(1).Row
         
             .Cells(LR, "e").NumberFormat = "@"
             .Cells(LR, "e").Value = .Cells(LR - 1, "e").Value
         
        End If
       
    Loop
      
      If Cells(LR, "A").Value = "" Then
      
            .Cells(LR, "E").NumberFormat = "General"
            .Cells(LR, "E").Value = ""
      
      End If
      
    Close #1
    
      End With
 Next
      
        ThisWorkbook.ActiveSheet.Range("A:E").Columns.AutoFit
   
       End If
End Sub

 

[aprendiz_vba]

@Basole Você é "o cara".

Ainda precisa de muito estudo pra conseguir fazer 1/3 do que fez aqui.

Me ajudou demais, super obrigada.

[Basole]

@aprendiz_vba de nada obrigado pelos elogios, eu também sou sempre um aprendiz 

[Ismael Souza]

@Basole Basole, como posso enviar mensagens pessoais a você??