aprendiz_vba

@Midori Boa noite!

Agradeço muito pela ajuda, mas vou necessitar de ti novamente.

No bloco do código que necessitava alteração, copiei, colei e fiz apenas a alteração nos números das colunas, pois o arquivo que te enviei não constava todos os dados.

A alteração que fez no código, a partir da segunda linha, além dos dados importados, está jogando também na primeira coluna, os últimos dados da linha anterior mais o último caractér.

Mais um caso que meu conhecimento técnico não permitiu arrumá-lo, por este motivo peço sua ajuda.

Boa tarde!

Tenho um arquivo texto delimitado ";" com duas duas informações de data, uma no formato mm/dd/aaaa que importou os dados corretamente no padrão que utilizamos aqui no Brasil. A outra  já com formato dd/mm/aaaa, somente dias maiores ou iguais a 13 que importou correto no nosso padrão, menores que 12, fica no padrão americano.

Não tenho a mínima noção de como arrumar isto. Alguém poderia me auxiliar com a alteração que devo fazer no código para solucionar este.

Envio o arquivo texto, com alguns dados para simulação.

Sub importa_delimitado()
   
    Dim entrada         As String       'linha do txt
    Dim i               As Single       'número de caracteres
    Dim linha           As Integer
    Dim coluna          As Integer
    Dim texto           As String       'texto a ser gravado na célula
    Dim ultimo          As Boolean      'controle do último caracter da linha
    Dim W               As Worksheet
    Dim Ficheiro        As String
    Dim FD              As FileDialog
    Dim strPath         As String
    Dim xFile           As String
    Dim xFiles          As New Collection
    Dim j               As Long
    Dim LR              As Long
            
   
    Set W = Sheets("Arquivo_importado")
    W.Select
    W.UsedRange.EntireColumn.Delete
      
    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 "Processo abortado." & Chr(13) & "Nenhum arquivo foi selecionado."
        Exit Sub
    End If
    
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = VBA.Dir()
    Loop
        
    Application.ScreenUpdating = False
    
    If xFiles.Count > 0 Then
          
    For j = 1 To xFiles.Count
        
    Ficheiro = strPath & xFiles.Item(j)
        
    With ThisWorkbook.ActiveSheet
    
     ' Adiciona nomes nas colunas
    For c = 1 To 11
    .Cells(1, 1).Value = "Id"
    .Cells(1, 2).Value = "Empl_rcd"
    .Cells(1, 3).Value = "Matrícula"
    .Cells(1, 4).Value = "Nome"
    .Cells(1, 5).Value = "Data Nascimento"
    .Cells(1, 6).Value = "Composição Salarial"
    .Cells(1, 7).Value = "Sexo"
    .Cells(1, 8).Value = "CPF"
    .Cells(1, 9).Value = "Cargo"
    .Cells(1, 10).Value = "Filial"
    .Cells(1, 11).Value = "Admissão"
    .Cells(1, c).Font.Bold = True
    .Cells(1, c).HorizontalAlignment = xlLeft
    Next c
    
    End With
       
        
    Open Ficheiro For Input As #1
             
    linha = 2
    coluna = 1

    Do While Not EOF(1)
        Line Input #1, entrada
        For i = 1 To Len(entrada)
            If Mid(entrada, i, 1) = ";" Then
                Cells(linha, coluna).Value = texto
                coluna = coluna + 1
                texto = ""
            Else
                'Se for o último caracter, grava na célula
                If i = Len(entrada) Then
                    texto = texto & Mid(entrada, i, 1)
                    Cells(linha, coluna).Value = texto
                    coluna = coluna + 1
                    texto = ""
                    ultimo = True
                End If
                If Not ultimo Then texto = texto & Mid(entrada, i, 1)
            End If
            ultimo = False
        Next
        linha = linha + 1
        coluna = 1
    Loop
           
    Close #1
  
    Next
        
    Cells(2, 6).Select
    Range(Selection, Selection.End(xlDown)).Select
    For Each cell In Selection
       numero = Str(cell.Value)
       cell.Activate
       ActiveCell.FormulaR1C1 = numero
    Next
    Selection.NumberFormat = "#,##0.00"
       
        
    ThisWorkbook.ActiveSheet.Range("E:E").HorizontalAlignment = xlRight
    ThisWorkbook.ActiveSheet.Range("A:K").Font.Size = 8
    ThisWorkbook.ActiveSheet.Range("A:K").Columns.AutoFit
        
    End If
    
    Application.ScreenUpdating = True
     
    MsgBox "Importação concluída com sucesso."

End Sub

Jun_2020_duvida.txt

Boa tarde.

Conseguiriam me auxiliar mais uma vez, por gentileza.

Localizei este código para importação CSV, porém quando fui conferir os dados importados, o último registro de cada arquivo não carrega, tentei identificar o erro no código abaixo, mas meu conhecimento não permitiu localizá-lo.

 Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    
    Set W = Sheets("Arq_Recarga_Certa")
    W.Select
    W.UsedRange.EntireColumn.Delete

    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Selecione o diretório que conste os arquivos de Recarga Certa"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.csv")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp)
        xWb.Close False
        xFile = Dir
    Loop

@Basole Você é "o cara".

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

Me ajudou demais, super obrigada.

@Basole Oi. Boa noite!

Consegui me ajudar com está importação?

@Basole Conforme solicitado, segue o resultado do Arquivo1.

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

Exemplo.xlsx

@Basole Boa noite!

Segue modelo de arquivos.

Agradeço mais uma vez

Arquivo1.txt Arquivo2.txt

@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, boa noite!

Gratidão pela ajuda.

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

@Basole

Boa noite!

Gratidão pela ajuda.

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

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