code - vba excel 2016

Listar archivos en la carpeta y subcarpeta con ruta al archivo.txt

Question

Esta pregunta ya tiene una respuesta aquí:

• obtener lista de subdires en vba 4 respuestas

Tengo una hoja de Excel que tiene una celda que contiene la ruta a un directorio, quiero una macro que busque en el directorio y en cualquier subdirectorio y enumere los archivos en un archivo .txt, con la ruta completa de cada archivo.

Esto es actualmente lo que he encontrado que parece que debería encontrar los archivos, excepto que la ruta está codificada y no hace nada con los resultados.

¿Alguna idea de cómo puedo cambiarla para que se ajuste a mis necesidades?

Sub LoopThroughFiles()
Dim StrFile As String
StrFile = Dir("C:/Work/NCL/nCLs/histogram_addition/TestData/Input/RTE/")
Do While Len(StrFile) > 0
    Debug.Print StrFile
    StrFile = Dir
Loop
End Sub

Answer 1

Aquí hay un método improvisado a partir de los ejemplos de FileSystemObject () usando una llamada recursiva. Aplique una clasificación a los resultados si es necesario. También puede filtrar por extensión .txt usando otros métodos FileSystemObject ():

    Sub Sample()
        ShowFolderList ("C:/temp")
    End Sub

    Sub ShowFolderList(folderspec)
        Dim fs, f, f1, fc, s, sFldr
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set f = fs.GetFolder(folderspec)
        Set fc = f.SubFolders
         For Each f1 In fc
            If Right(f1, 1) <> "/" Then ShowFolderList f1 & "/" Else ShowFolderList f1
        Next
        Set fc = f.Files
        For Each f1 In fc
            Debug.Print folderspec & f1.Name
        Next
    End Sub

Escribir en el archivo:

    Option Explicit

    Dim file As Object
    Dim fs As Object

    Sub go()
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set file = fs.OpenTextFile("C:/temp2/results3.txt", 2, True) '' 2=ForWriting, replace
        ShowFolderList "C:/temp/"
        file.Close
        MsgBox "done"
    End Sub

    Sub ShowFolderList(folderspec)
    On Error GoTo local_err
        Dim f, f1, fc, s, sFldr
        Set f = fs.GetFolder(folderspec)
        Set fc = f.SubFolders
         For Each f1 In fc
            If Right(f1, 1) <> "/" Then ShowFolderList f1 & "/" Else ShowFolderList f1
        Next
        Set fc = f.Files
        For Each f1 In fc
            file.writeline folderspec & f1.Name
        Next
     local_exit:
        Exit Sub
     local_err:
        MsgBox Err & " " & Err.Description
        Resume local_exit
        Resume
    End Sub