Ir ao conteúdo
  • Cadastre-se
aprendiz_vba

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

Posts recomendados

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

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

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.

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

Esses seus codigos estão muito confusos. 😲

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

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@Basole Conforme solicitado, segue o resultado do Arquivo1.

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

Exemplo.xlsx

Compartilhar este post


Link para o post
Compartilhar em outros sites

@Basole Oi. Boa noite!

Consegui me ajudar com está importação?

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...

GRÁTIS: minicurso “Como ganhar dinheiro montando computadores”

Gabriel TorresGabriel Torres, fundador e editor executivo do Clube do Hardware, acaba de lançar um minicurso totalmente gratuito: "Como ganhar dinheiro montando computadores".

Você aprenderá sobre o quanto pode ganhar, como cobrar, como lidar com a concorrência, como se tornar um profissional altamente qualificado e muito mais!

Inscreva-se agora!