Passa attraverso sottocartelle e file in una directory radice specificata dall'utente

Question

Il mio script ciclico attraverso singoli file funziona bene, ma ora ho bisogno che guardi anche attraverso/per più directory. Sono bloccato ....

L'ordine le cose devono accadere:

• viene richiesto all'utente di scegliere directory principale di ciò di cui hanno bisogno
• ho bisogno lo script per cercare eventuali cartelle in quella radice directory
• Se lo script ne trova uno, apre il primo (tutte le cartelle, quindi nessun filtro di ricerca specifico per le cartelle)
• Una volta aperto, il mio script eseguirà un ciclo di tutti i file nelle cartelle e farà ciò di cui ha bisogno do
• dopo che è finito chiude il file, chiude la directory e si sposta al prossimo, ecc ..
• loop fino a quando tutte le cartelle sono stati aperti/scansione

Questo è quello che ho, che non lo fa lavoro e so che è sbagliato:

MsgBox "Please choose the folder." 
Application.DisplayAlerts = False 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .InitialFileName = "\\blah\test\" 
    .AllowMultiSelect = False 
    If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
    CSRootDir = .SelectedItems(1) 
End With 
folderPath = Dir(CSRootDir, "\*") 

Do While Len(folderPath) > 0 
    Debug.Print folderPath 
    fileName = Dir(folderPath & "*.xls") 
    If folderPath <> "False" Then 
     Do While fileName <> "" 
      Application.ScreenUpdating = False 
      Set wbkCS = Workbooks.Open(folderPath & fileName) 

      --file loop scripts here 

     Loop 'back to the Do 
Loop 'back to the Do 

Codice finale. Passa in rassegna tutte le sottodirectory e i file in ogni sottodirectory.

Dim FSO As Object, fld As Object, Fil As Object 
Dim fsoFile As Object 
Dim fsoFol As Object 
Dim fileName As String 

    MsgBox "Please choose the folder." 
    Application.DisplayAlerts = False 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .InitialFileName = "\\blah\test\" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
     folderPath = .SelectedItems(1) 
    End With 

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
     Set FSO = CreateObject("Scripting.FileSystemObject") 
     Set fld = FSO.getfolder(folderPath) 
    If FSO.folderExists(fld) Then 
     For Each fsoFol In FSO.getfolder(folderPath).subfolders 
       For Each fsoFile In fsoFol.Files 
        If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then 
    fileName = fsoFile.Name 
    Application.ScreenUpdating = False 
    Set wbkCS = Workbooks.Open(fsoFile.Path) 

    'My file handling code 


       End If 
       Next 
     Next 
    End If 

Answer 1

Si potrebbe trovare più facile da usare il FileSystemObject, somthing come questo

Questo dump un elenco di cartelle/file alla Immediate window

Option Explicit 

Sub Demo() 
    Dim fso As Object 'FileSystemObject 
    Dim fldStart As Object 'Folder 
    Dim fld As Object 'Folder 
    Dim fl As Object 'File 
    Dim Mask As String 

    Set fso = CreateObject("scripting.FileSystemObject") ' late binding 
    'Set fso = New FileSystemObject 'or use early binding (also replace Object types) 

    Set fldStart = fso.GetFolder("C:\Your\Start\Folder") ' <-- use your FileDialog code here 

    Mask = "*.xls" 
    Debug.Print fldStart.Path & "\" 
    ListFiles fldStart, Mask 
    For Each fld In fldStart.SubFolders 
     ListFiles fld, Mask 
     ListFolders fld, Mask 
    Next 
End Sub 


Sub ListFolders(fldStart As Object, Mask As String) 
    Dim fld As Object 'Folder 
    For Each fld In fldStart.SubFolders 
     Debug.Print fld.Path & "\" 
     ListFiles fld, Mask 
     ListFolders fld, Mask 
    Next 

End Sub 

Sub ListFiles(fld As Object, Mask As String) 
    Dim fl As Object 'File 
    For Each fl In fld.Files 
     If fl.Name Like Mask Then 
      Debug.Print fld.Path & "\" & fl.Name 
     End If 
    Next 
End Sub 

Answer 2

Sub MoFileTrongCacFolder() 

    Dim FSO As Object, fld As Object, Fil As Object 
    Dim fsoFile As Object 
    Dim fsoFol As Object 
    Dim fileName As String 
    Dim folderPath As String 
    Dim wbkCS As Object 

    MsgBox "Please choose the folder." 
    Application.DisplayAlerts = False 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .InitialFileName = "\\blah\test\" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
     folderPath = .SelectedItems(1) 
    End With 

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
    Set FSO = CreateObject("Scripting.FileSystemObject") 
    Set fld = FSO.getfolder(folderPath) 
    If FSO.folderExists(fld) Then 
     For Each fsoFol In FSO.getfolder(folderPath).subfolders 
      For Each fsoFile In fsoFol.Files 
       If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then 
        fileName = fsoFile.Name 
        Application.ScreenUpdating = False 
        Set wbkCS = Workbooks.Open(fsoFile.Path) 

        'My file handling code 


       End If 
      Next 
     Next 
    End If 
End Sub 

Answer 3

Ecco una soluzione di VBA, senza usare oggetti esterni.

A causa delle limitazioni della funzione Dir() è necessario ottenere l'intero contenuto di ciascuna cartella contemporaneamente, non durante la scansione con un algoritmo ricorsivo.

Function GetFilesIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFilesIn = New Collection 
    F = Dir(Folder & "\*") 
    Do While F <> "" 
    GetFilesIn.Add F 
    F = Dir 
    Loop 
End Function 

Function GetFoldersIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFoldersIn = New Collection 
    F = Dir(Folder & "\*", vbDirectory) 
    Do While F <> "" 
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F 
    F = Dir 
    Loop 
End Function 

Sub Test() 
    Dim C As Collection, F 

    Debug.Print 
    Debug.Print "Files in C:\" 
    Set C = GetFilesIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "Folders in C:\" 
    Set C = GetFoldersIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 
End Sub