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

@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. adicionado 47 minutos depois @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