Actualizar: nombre del archivo txt en la columna A, todas las filas. (Macro)
Tengo la siguiente macro y quiero que cuando cargue la información de los archivos txt, en la columna A en todas la filas se vea el nombre del archivo txt que contiene la información.
Sub ConvertirTxt()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Hoja1")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = l1.Path & "\"
If .Show <> -1 Then Exit Sub
ruta = .SelectedItems(1) & "\"
End With
'
arch = Dir(ruta & "*.txt")
'
Do While arch <> ""
Workbooks.OpenText Filename:=ruta & arch, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1)), _
TrailingMinusNumbers:=True
Set l2 = ActiveWorkbook
Set h2 = l2.Sheets(1)
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
If u = 2 And h1.[A1] = "" Then u = 1
h2.UsedRange.Copy h1.Cells(u, "A")
arch = Dir()
l2.Close False
Loop
Application.ScreenUpdating = True
MsgBox "Archivos cargados", vbInformation, "CONVERTIR TXT"
End Sub
1 Respuesta
H o l a:
Te anexo la macro actualizada
Sub ConvertirTxt()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Hoja1")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = l1.Path & "\"
If .Show <> -1 Then Exit Sub
ruta = .SelectedItems(1) & "\"
End With
'
arch = Dir(ruta & "*.txt")
'
Do While arch <> ""
Workbooks.OpenText Filename:=ruta & arch, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1)), _
TrailingMinusNumbers:=True
Set l2 = ActiveWorkbook
Set h2 = l2.Sheets(1)
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
If u = 2 And h1.[A1] = "" Then u = 1
h2.UsedRange.Copy h1.Cells(u, "A")
l2.Close False
un = h1.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("A" & u & ":A" & un).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
h1.Range("A" & u & ":A" & un) = arch
arch = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Archivos cargados", vbInformation, "CONVERTIR TXT"
End Sub