VBA Parcourez le dossier et les sous-dossiers pour trouver une feuille spécifique puis copiez et collez certaines données

Question

J'espère que vous pourrez m'aider. J'ai essayé de coder ceci moi-même (voir le code ci-dessous), mais j'ai échoué, alors je demande de l'aide à la communauté.

Ce que j'ai besoin de mon code est de permettre à un utilisateur de cliquer sur un bouton de commande, puis l'utilisateur sélectionne un dossier. Une fois ce dossier est sélectionné. J'ai besoin du code pour regarder ou d'une boucle à travers ce dossier et tous les sous-dossiers dans ce dossier et de trouver des feuilles avec un nom comme « CustomerExp » puis copier les données dans les feuilles nommer comme « CustomerExp » de la deuxième rangée jusqu'à la dernière rangée utilisée et collez l'information dans une feuille appelée "Disputes" où la macro est logée.

J'ai fourni des images pour une meilleure compréhension.

Pic 1 est où la macro est logée et où j'ai besoin de l'info collée.

Pic 1

Pic 2 est le premier fichier que l'utilisateur sélectionnera et le seul que je veux qu'ils sélectionner

Pic 2

Pic 3, vous pouvez voir que dans le dossier 2017 il y a plusieurs autres dossiers

Pic 3

Pic 4 Encore une fois, vous pouvez voir que nous avons le fichier que je cherche en plus d'autres dossiers qui doivent être bouclées

Pic 4

Essentiellement ce que j'ai besoin code à faire est de permettre à la personne de sélectionner 2017 dossier cliquez sur OK, puis le code passe par tout dans le dossier 2017 trouve les fichiers avec des noms Comme "CustomerExp" copie les données et colle sur la feuille "Disputes" dans la feuille où la macro est tenue.

Mon code compile mais ne fait rien. Comme toujours, toute aide est grandement appréciée.

MON CODE

Sub AllWorkbooks() 

    Dim MyFolder As String 'Path collected from the folder picker dialog 
    Dim myFile As String 'Filename obtained by DIR function 
    Dim wbk As Workbook 'Used to loop through each workbook 
    Dim FSO As New FileSystemObject ' Requires "Windows Script Host Object Model" in Tools -> References 
    Dim ParentFolder As Object, ChildFolder As Object 

    Dim wb As Workbook 
    Dim myPath As String  
    Dim myExtension As String 
    Dim FldrPicker As FileDialog 
    Dim lRow As Long 
    Dim ws2 As Worksheet 
    Dim y As Workbook 

    On Error Resume Next 
    Application.ScreenUpdating = False 

    'Opens the folder picker dialog to allow user selection 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .Title = "Please select a folder" 
     .Show 
     .AllowMultiSelect = False 

     If .SelectedItems.Count = 0 Then 'If no folder is selected, abort 
      MsgBox "You did not select a folder" 
      Exit Sub 
     End If  
     MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder 
    End With 

    myFile = Dir(MyFolder) 'DIR gets the first file of the folder   

    Set y = ThisWorkbook 
    Set ws2 = y.Sheets("Disputes") 

    'Loop through all files in a folder until DIR cannot find anymore 
    Do While myFile <> "" 

     If myFile Like "*CustomerExp*" Then         
      'Opens the file and assigns to the wbk variable for future use 
      Set wbk = Workbooks.Open(Filename:=MyFolder & myFile) 
      'Replace the line below with the statements you would want your macro to perform 
      With wb.Sheets(1) 
       lRow = .Range("A" & Rows.Count).End(xlUp).Row 
       .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) 
      End With 

      Application.Wait (Now + TimeValue("0:00:05")) 
      wbk.Close savechanges:=True    
     End If 
     myFile = Dir 'DIR gets the next file in the folder        
    Loop 

    For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders 
     myFile = Dir(MyFolder & ChildFolder.Name) 'DIR gets the first file of the folder 
     'Loop through all files in a folder until DIR cannot find anymore 
     Do While myFile <> "" 

     If myFile Like "*CustomerExp*" Then    
      'Opens the file and assigns to the wbk variable for future use 
      Set wbk = Workbooks.Open(Filename:=MyFolder & ChildFolder.Name & "\" & myFile) 
      'Replace the line below with the statements you would want your macro to perform 
      With wb.Sheets(1) 
       lRow = .Range("A" & Rows.Count).End(xlUp).Row 
       .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) 
      End With 

      Application.Wait (Now + TimeValue("0:00:05")) 
      wbk.Close savechanges:=True 
     End If 
     myFile = Dir 'DIR gets the next file in the folder 
    Loop 
Next ChildFolder 

Application.ScreenUpdating = True 

End Sub 

Answer 1

Juste quelques petits problèmes dans votre code:

1.With wb.Sheets(1) devrait être With wbk.Sheets(1)

suivie

lRow = .Range("A" & Rows.Count).End(xlUp).Row devrait être lRow = .Range("A" & .Rows.Count).End(xlUp).Row

comme déjà souligné par @ShaiRado dans les commentaires

Vous devez faire des changements ci-dessus à deux endroits. Tout d'abord dans

Do While myFile <> "" 


Loop 

puis à nouveau en do while intérieur pour chaque boucle

For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders 

Do While myFile <> "" 


Loop 

Next ChildFolder 

2.myFile = Dir(MyFolder & ChildFolder.Name) devrait être myFile = Dir(MyFolder & ChildFolder.Name & "\")