Résumer plusieurs documents en un seul

[benjamin.prade]

Bonjour à tous,

J'ai actuellement une question sur la possibilité de modification d'une macro déjà existante.
J'ai créé une macro qui me permet d'ouvrir à la suite plusieurs fichiers Excel contenus dans un seul et même dossier et de copier une plage de donnée spécifique provenant de chaque fichier pour la coller dans un autre fichier récapitulatif. Le code est le suivant :

Sub Essai()

Dim Fichier As String, Chemin As String
Dim i As Integer
Dim U As String
Dim Wb As Workbook

i = 5

Chemin = Range("B21")

Fichier = Dir(Chemin & "*.xls")


Do While Fichier <> ""

Set Wb = Workbooks.Open(Chemin & Fichier)

Sheets("Feuil1").Activate

Range("C2:C10").Select

Selection.Copy

Workbooks("Récapitulatif des données joueurs").Worksheets("Feuil1").Activate

Range("B" & i).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True


Wb.Close True

Set Wb = Nothing

Fichier = Dir

i = i + 1


Voici ma question/problème concernant cette macro.

Est-il possible de créer la même macro mais qui va ouvrir des fichiers avec une arborescence contenant des sous-dossiers? (pour l'instant j'ai un dossier contenant tous mes fichiers où sont contenues les données à extraire et j'aimerais pouvoir les classer dans des sous-dossiers).

En gros pour le moment j'ai un dossier contenant des fiches de joueurs qui s'organise comme ceci :

Fichiers données

Joueur1.xls​

Joueur2.xls​

...

Joueur9.xls​

Et j'aimerais un dossiers contenant plusieurs sous-dossiers pour pouvoir trier mes fichiers Excel :

Fichier données

Attaquants​

Joueur1.xls​

Joueur2.xls​

Joueur3.xls​

Milieux​

Joueur4.xls​

Joueur5.xls​

Joueur6.xls​

Défenseurs​

Joueur7.xls​

Joueur8.xls​

Joueur9.xls​

Je vous remercie par avance.

 

[Macgiy]

Re : Résumer plusieurs documents en un seul

Bonjour Benjamin,

Je te propose ce code qui nécessitera quelques ajustement pour coller à tes noms de fichiers mais je pense que la structure est adaptée et pourra t'aider.

Ce code a été écrit par Pierrot93 il y a quelques années :

Option Explicit
Sub test()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
 
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\TEST EXCEL\"
 
For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    For Each f2 In f1.Files
        Set wb = Workbooks.Open(f2)
        'tes instructions
        wb.Close
     Next f2
Next f1
End Sub

En espérant que cela t'aide