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

Respuesta
1

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas