Visual Basic Importação arquivo texto erro data

aprendiz_vba · 11 de agosto de 2020

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

Midori · 12 de agosto de 2020

@aprendiz_vba Você pode tentar usar uma função para inverter o dia com o mês da data, p.ex

Function DataDMA(StrData As String)
    DataDMA = Split(StrData, "/")(1) & "/" & Split(StrData, "/")(0) & "/" & Split(StrData, "/")(2)
End Function

A parte com a alteração,

        For i = 1 To Len(entrada)
            If Mid(entrada, i, 1) = ";" Then
                If coluna = 3 Or coluna = 4 Then texto = DataDMA(texto)
                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)
                   If coluna = 3 Or coluna = 4 Then texto = DataDMA(texto)
                    Cells(linha, coluna).Value = texto
                    coluna = coluna + 1
...

Obs: Uma melhoria que você pode fazer no código é usar Split para pegar os campos do arquivo, assim não terá necessidade de usar loop para identificar ;. Veja neste tópico como fazer:

aprendiz_vba · 13 de agosto de 2020

@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.

Midori · 14 de agosto de 2020

@aprendiz_vba Tente usar a função Split como sugeri acima, é uma forma muito mais fácil e segura de pegar os campos do arquivo.

Fiz a adaptação no seu código nesta parte, veja como é mais simples,

    Do While Not EOF(1)
        Line Input #1, entrada
            Cells(linha, 1).Value = Split(entrada, ";")(0)
            Cells(linha, 2).Value = Split(entrada, ";")(1)
            Cells(linha, 3).Value = DataDMA(Split(entrada, ";")(2))
            Cells(linha, 4).Value = DataDMA(Split(entrada, ";")(3))
        linha = linha + 1
    Loop
           
    Close #1

Não precisa usar loop para identificar as colunas no arquivo, basta informar o índice da coluna (de 0 até n). Acima p.ex o índice 0 é o Id, o 1 é Empl_rcd, etc.

O código completo fica assim,

Function DataDMA(ByVal StrData As String)
    DataDMA = Split(StrData, "/")(1) & "/" & Split(StrData, "/")(0) & "/" & Split(StrData, "/")(2)
End Function

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
            Cells(linha, 1).Value = Split(entrada, ";")(0)
            Cells(linha, 2).Value = Split(entrada, ";")(1)
            Cells(linha, 3).Value = DataDMA(Split(entrada, ";")(2))
            Cells(linha, 4).Value = DataDMA(Split(entrada, ";")(3))
        linha = linha + 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