Excel VBA: Sélectionnez plusieurs dossiers

Question

J'ai actuellement une macro qui vérifie un dossier pour les fichiers Excel et exécute quelques ajustements de type de formatage (ajoute des colonnes, etc.).

Le problème est que cela me permettra seulement de sélectionner un dossier et de vérifier là-dedans. Il y a beaucoup de dossiers dont j'ai besoin pour vérifier que tous existent dans le même répertoire.

Je ne peux pas sélectionner plus d'un dossier à archiver, même en ajustant AllowMultiSelect à True. Comment puis-je modifier ce code afin qu'il me permette de sélectionner tous les dossiers dans un répertoire?

Sub Button1_Click() 

Dim wb As Workbook 
Dim myPath As String 
Dim myFile As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 


    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     myPath = .SelectedItems(1) & "\" 
    End With 

    NextCode: 
    myPath = myPath 
    If myPath = "" Then GoTo ResetSettings 

    myExtension = "*.xls" 

    myFile = Dir(myPath & myExtension) 

    Do While myFile <> "" 
     Set wb = Workbooks.Open(fileName:=myPath & myFile) 

     DoEvents 

     'Formatting adjustments etc go here 

     wb.Close SaveChanges:=True 

     DoEvents 

     myFile = Dir 

    Loop 

    MsgBox "Complete." 



End Sub 

Answer 1

Je pense que je trouve une meilleure solution que de sélectionner manuellement tous les dossiers. Vous avez dit que tous vos fichiers se trouvent dans un répertoire, dans lequel se trouvent des sous-dossiers. Avec le code ci-dessous, vous parcourrez tous les fichiers dans le dossier que vous choisissez. Vous allez stocker toutes les logiques de formatage dans le sous-formatage.

Sub Button1_Click() 
Dim objFolder As Object 
Dim objFile As Object 
Dim objFSO As Object 
Dim MyPath As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     MyPath = .SelectedItems(1) 
    End With 


    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Call GetAllFiles(MyPath, objFSO) 
    Call GetAllFolders(MyPath, objFSO) 

    MsgBox "Complete." 

NextCode: 
End Sub 
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object) 
Dim objFolder As Object 
Dim objFile As Object 

    Set objFolder = objFSO.GetFolder(strPath) 
    For Each objFile In objFolder.Files 
      Formatting (objFile.Path) 
    Next objFile 
End Sub 

Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object) 
Dim objFolder As Object 
Dim objSubFolder As Object 

    Set objFolder = objFSO.GetFolder(strFolder) 
    For Each objSubFolder In objFolder.subfolders 
     Call GetAllFiles(objSubFolder.Path, objFSO) 
     Call GetAllFolders(objSubFolder.Path, objFSO) 
    Next objSubFolder 
End Sub 

Sub Formatting(strFile As String) 
Dim wb As Workbook 
    If Right(strFile, 3) = "xls" Then 
     Set wb = Workbooks.Open(Filename:=MyPath & myFile) 
     DoEvents 

     'Formatting adjustments etc go here 

     wb.Close SaveChanges:=True 
     DoEvents 
     myFile = Dir 
    End If 
End Sub 

Answer 2

Que diriez-vous de ce concept? Vous mappez récursivement à tous les fichiers de tous les dossiers et créez un schéma de votre structure de dossiers entière. Ensuite, contrôlez chaque fichier en fonction de chaque chemin de dossier.

Option Explicit 

Sub ListAllFiles() 
     searchForFiles "C:\your_path_here\", "writefilestosheet", "*.*", True, True 
    End Sub 

    Sub processOneFile(ByVal aFilename As String) 
     Debug.Print aFilename 
    End Sub 

    Sub writeFilesToSheet(ByVal aFilename As String) 
     With ActiveSheet 
     .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename 
      End With 
    End Sub 


    Private Sub processFiles(ByVal DirToSearch As String, _ 
       ByVal ProcToCall As String, _ 
       ByVal FileTypeToFind As String) 
      Dim aFile As String 
      aFile = Dir(DirToSearch & FileTypeToFind) 
      Do While aFile <> "" 
       Application.Run ProcToCall, DirToSearch & aFile 
       aFile = Dir() 
       Loop 
    End Sub 

    Private Sub processSubFolders(ByVal DirToSearch As String, _ 
       ByVal ProcToCall As String, _ 
       ByVal FileTypeToFind As String, _ 
       ByVal SearchSubDir As Boolean, _ 
       ByVal FilesFirst As Boolean) 

    Dim aFolder As String, SubFolders() As String 

    ReDim SubFolders(0) 

    aFolder = Dir(DirToSearch, vbDirectory) 

     Do While aFolder <> "" 

      If aFolder <> "." And aFolder <> ".." Then 

       If (GetAttr(DirToSearch & aFolder) And vbDirectory) _ 
         = vbDirectory Then 
        SubFolders(UBound(SubFolders)) = aFolder 
        ReDim Preserve SubFolders(UBound(SubFolders) + 1) 
        End If 
        End If 
       aFolder = Dir() 
       Loop 

      If UBound(SubFolders) <> LBound(SubFolders) Then 
       Dim i As Long 
       For i = LBound(SubFolders) To UBound(SubFolders) - 1 
        searchForFiles _ 
         DirToSearch & SubFolders(i), _ 
         ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst 
        Next i 
       End If 

     End Sub 

    Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _ 
      Optional ByVal FileTypeToFind As String = "*.*", _ 
      Optional ByVal SearchSubDir As Boolean = False, _ 
      Optional ByVal FilesFirst As Boolean = False) 
     On Error GoTo ErrXIT 
     If Right(DirToSearch, 1) <> Application.PathSeparator Then _ 
      DirToSearch = DirToSearch & Application.PathSeparator 

    If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind 
    If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _ 
     FileTypeToFind, SearchSubDir, FilesFirst 

     If Not FilesFirst Then _ 
      processFiles DirToSearch, ProcToCall, FileTypeToFind 
     Exit Sub 
    ErrXIT: 
     MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")" 
     Exit Sub 
    End Sub