Bonjour, à tous !

Grâce à l'aide d'un de vos collègues j'ai pu développer une macro qui interroge un répertoire pour en extraire des données contenues dans des fichiers excel de nombre inconnu.

Cette macro utilise le MSR.

J'encontre en revanche un petit souci ...

Jusqu’à présent je faisais tourner la macro sur le "Thiswoorkbook" et elle faisait des extractions sur la "Feuil1"
Pour un souci de pratique je voudrais qu'elle fasse une extraction sur la "Feuil2"
Je pensais que ça allait être relativement simple à faire, mais je n'ai vraiment pas réussi à la faire changer ...

Sauriez-vous comment je pourrais faire ce petit changement svp ??

Au passage je n'ai pas forcément compris toutes les lignes de cette macro si vous avez quelques explications je suis preneur

Code originel :

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub ParcourirDossier()
 
Dim FichierSélectionné As String
Dim NumFichier As Integer
Dim fs As FileDialog
Dim DossierSélectionné As Folder
 
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
 
 
    Set FichierPrincipal = ThisWorkbook
    Set FeuilleCompil = FichierPrincipal.Sheets("Feuil1")
    Set fs = Application.FileDialog(msoFileDialogFolderPicker)
    fs.Title = "Selection du dossier à parcourir"
    fs.AllowMultiSelect = False
    fs.InitialFileName = Chemin
    fs.Show
    If fs.SelectedItems.Count < 1 Then Exit Sub
    Set fso = New FileSystemObject
    Set DossierSélectionné = fso.GetFolder(fs.SelectedItems(1))
 
    Call scan(DossierSélectionné)
 
End Sub
 
Sub scan(ByVal Dossier As Folder)
 
Dim NomFichier As String
Dim Classeur As Workbook
 
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" Then 'Permet d'exclure les fichier temporaires
                    Workbooks.Open Fichier
                    Set Classeur = ActiveWorkbook
 
                    Classeur.Sheets(2).Range("A1").CurrentRegion.Copy
 
                    ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
 
 
                    Classeur.Close False
                End If
        End Select
    Next Fichier
 
    For Each Sousdossier In Dossier.SubFolders
        Call scan(Sousdossier)
    Next
 
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
 
End Sub
Code rectifié (Défectueux) :

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub ParcourirDossier()
 
Dim FichierSélectionné As String
Dim NumFichier As Integer
Dim fs As FileDialog
Dim DossierSélectionné As Folder
 
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
 
 
    Set FichierPrincipal = ThisWorkbook
    Set FeuilleCompil = FichierPrincipal.Sheets("Feuil2")
    Set fs = Application.FileDialog(msoFileDialogFolderPicker)
    fs.Title = "Selection du dossier à parcourir"
    fs.AllowMultiSelect = False
    fs.InitialFileName = Chemin
    fs.Show
    If fs.SelectedItems.Count < 1 Then Exit Sub
    Set fso = New FileSystemObject
    Set DossierSélectionné = fso.GetFolder(fs.SelectedItems(1))
 
    Call scan(DossierSélectionné)
 
End Sub
 
Sub scan(ByVal Dossier As Folder)
 
Dim NomFichier As String
Dim Classeur As Workbook
 
    For Each Fichier In Dossier.Files
        Select Case Right(Fichier, 3)
            Case "xls", "lsx", "lsm", "lsb"
                If Left(Fichier.Name, 1) <> "~" Then 'Permet d'exclure les fichier temporaires
                    Workbooks.Open Fichier
                    Set Classeur = ActiveWorkbook
 
                    Classeur.Sheets(2).Range("A1").CurrentRegion.Copy
 
                    ThisWorkbook.Sheets(2).Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
 
 
                    Classeur.Close False
                End If
        End Select
    Next Fichier
 
    For Each Sousdossier In Dossier.SubFolders
        Call scan(Sousdossier)
    Next
 
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
 
End Sub
Merci d'avance pour vos réponses !