Copiar contenido de archivos de Texto a Excel.

Prueba esta macro:

IMPORTANTE:

En la fila que empieza:    ruta = .......

Tienes que pegar el path del primer nivel de tus carpetas, es decir, la primera carpeta de todas.

Sub proceso()
'por luismondelo
Application.DisplayAlerts = False
mio = ActiveWorkbook.Name
ruta = "C:\Users\luismondelo\Documents\NIVEL1\" 'este es el primer nivel
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(ruta)
For Each subcarpeta In carpeta.subfolders
For Each subcarpeta2 In subcarpeta.subfolders
For Each fichero In subcarpeta2.Files
MsgBox fichero.Name
Workbooks.OpenText fichero, origin:=xlWindows, startrow:=1
otro = ActiveWorkbook.Name
Range("a1").CurrentRegion.Copy
Workbooks(mio).Activate
Range("a65000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks(otro).Close False
Next
Next
Next
End Sub

Te anexo la macro corregida. En la Hoja1 te agrega la información y en la Hoja2 te pone los directorios y los archivos que fueron agregados.

Dim j
Dim rutas As New Collection
Sub carpetasysub()
'Por.Dante Amor
'lista archivos de una carpeta y todas las subcarpetas y todos sus archivos
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Hoja1")
    Set h2 = l1.Sheets("Hoja2")
    '
    h1.Cells.Clear
    h2.Select
    h2.Cells.Clear
    h2.Range("A1:C1") = Array("DIRECTORIO", "SUBDIRECTORIO", "ARCHIVOS")
    pPath = "C:\"
    ext = "txt"
    '
    Set n = CreateObject("shell.application")
        carpeta = n.browseforfolder(0, _
                "Selecciona el Directorio Inical", 0, _
                pPath).items.Item.Path
    '
    If carpeta = "" Then Exit Sub
    '
    pPath = carpeta & "\"
    '
    h2.Range("A2") = pPath
    j = 2
    rutas.Add carpeta
    Call agregadir(pPath)
    '
    j = 2
    For Each sd In rutas
        arch = Dir(sd & "\*." & ext)
        h2.Range("B" & j) = sd
        Do While arch <> ""
            h2.Range("C" & j) = arch
            '
            Set l2 = Workbooks.Open(sd & "\" & arch)
            '
            Set h3 = l2.ActiveSheet
            u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row
            h3.UsedRange.Copy h1.Range("A" & u)
            l2.Close
            arch = Dir
            j = j + 1
        Loop
    Next
    '
    Set rutas = Nothing
    h2.Columns("A:C").EntireColumn.AutoFit
    h1.Select
    Application.ScreenUpdating = False
    MsgBox "Fin, copiar archivos txt", vbInformation, "ARCHIVOS"
End Sub
Sub agregadir(lpath)
'Agrega directorios
'Por.Dante Amor
    Dim SubDir As New Collection
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> ""
        'Agrega subdirectorios a collection
        If DirFile <> "." And DirFile <> ".." Then _
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
                SubDir.Add lpath & DirFile
        DirFile = Dir
    Loop
    For Each sd In SubDir
        'Range("A" & j) = sd
        j = j + 1
        rutas.Add sd
        Call agregadir(sd)
    Next
End Sub