Importer des données de plusieurs classeurs dans plusieurs dossiers

Version imprimable

Bonjour,

Je suis en mesure d'importer plusieurs feuille dans un même répertoire avec ce code

Code:

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
57
58
59
60
61
Option Explicit
Dim P As String, F As String, S As String, A As String
Dim Arg As String
Dim Dossier As Object, Fichier As Object
Private Function GetValue(Path, File, Sheet, Ref)
If Right(Path, 1) <> "\" Then Path = Path & "\"
If Dir(Path & File) = "" Then
GetValue = "File Not Found"
Exit Function
End If
Arg = "'" & Path & "[" & File & "]" & Sheet & "'!" & Range(Ref).Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(Arg)
End Function
Sub Recuperation()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ThisWorkbook.Sheets("Extraction").Range("B4").CurrentRegion.Offset(1, 0).ClearContents
P = ThisWorkbook.Path 'Chemin du dossier à analyser (à adapter au besoin)
Set Dossier = CreateObject("Scripting.FileSystemObject").getfolder(P) 'Attribue une référence d'objet à la variable
For Each Fichier In Dossier.Files 'Boucle sur les fichier *.xlsx
If Right(Fichier.Name, 9) = "1819.xlsm" Then ' Tri des fichiers Excel
'Transfert des données
With ThisWorkbook.Sheets("Extraction").Range("B1000")
If ThisWorkbook.Name <> Fichier.Name Then
.End(xlUp).Offset(1, 0) = Fichier.Name
F = Fichier.Name: S = "extraction": A = "B2": .End(xlUp).EntireRow.Range("C1").Value = GetValue(P, F, S, A)
A = "c2": .End(xlUp).EntireRow.Range("D1").Value = GetValue(P, F, S, A)
A = "d2": .End(xlUp).EntireRow.Range("E1").Value = GetValue(P, F, S, A)
A = "E2": .End(xlUp).EntireRow.Range("F1").Value = GetValue(P, F, S, A)
A = "f2": .End(xlUp).EntireRow.Range("g1").Value = GetValue(P, F, S, A)
A = "g2": .End(xlUp).EntireRow.Range("h1").Value = GetValue(P, F, S, A)
A = "h2": .End(xlUp).EntireRow.Range("i1").Value = GetValue(P, F, S, A)
A = "i2": .End(xlUp).EntireRow.Range("j1").Value = GetValue(P, F, S, A)
A = "j2": .End(xlUp).EntireRow.Range("k1").Value = GetValue(P, F, S, A)
A = "k2": .End(xlUp).EntireRow.Range("l1").Value = GetValue(P, F, S, A)
A = "l2": .End(xlUp).EntireRow.Range("m1").Value = GetValue(P, F, S, A)
A = "m2": .End(xlUp).EntireRow.Range("n1").Value = GetValue(P, F, S, A)
A = "n2": .End(xlUp).EntireRow.Range("o1").Value = GetValue(P, F, S, A)
A = "o2": .End(xlUp).EntireRow.Range("p1").Value = GetValue(P, F, S, A)
A = "p2": .End(xlUp).EntireRow.Range("q1").Value = GetValue(P, F, S, A)
A = "q2": .End(xlUp).EntireRow.Range("r1").Value = GetValue(P, F, S, A)
A = "r2": .End(xlUp).EntireRow.Range("s1").Value = GetValue(P, F, S, A)
A = "s2": .End(xlUp).EntireRow.Range("t1").Value = GetValue(P, F, S, A)
A = "t2": .End(xlUp).EntireRow.Range("u1").Value = GetValue(P, F, S, A)
A = "U2": .End(xlUp).EntireRow.Range("v1").Value = GetValue(P, F, S, A)
A = "V2": .End(xlUp).EntireRow.Range("w1").Value = GetValue(P, F, S, A)
A = "x2": .End(xlUp).EntireRow.Range("y1").Value = GetValue(P, F, S, A)
A = "y2": .End(xlUp).EntireRow.Range("z1").Value = GetValue(P, F, S, A)
A = "z2": .End(xlUp).EntireRow.Range("aa1").Value = GetValue(P, F, S, A)
A = "aa2": .End(xlUp).EntireRow.Range("ab1").Value = GetValue(P, F, S, A)
A = "ab2": .End(xlUp).EntireRow.Range("ac1").Value = GetValue(P, F, S, A)
A = "ac2": .End(xlUp).EntireRow.Range("ad1").Value = GetValue(P, F, S, A)
A = "ad2": .End(xlUp).EntireRow.Range("ae1").Value = GetValue(P, F, S, A)
 
End If
End With
End If
Next Fichier
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

mais je cherche à le faire dans tout les sous dossiers qui sont dans le répertoire "P:\dossiers"

Merci

11/10/2018, 09h32
Menhir

L'une des règles du forum précise qu'il faut lire la FAQ avant de poser une question.
Tu aurais dû lire ça : https://excel.developpez.com/faq/?pa...riptingRuntime

Merci c'est très bien comme macro, mais comment puis-je extraire les données par exemple d'une cellule dans chaque fichier.

Code:

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
57
58
59
60
61
62
63
64
65
66
67
Option Explicit
 
Sub TestListeFichiers()
    Dim Dossier As String
 
    'Définit le répertoire pour débuter la recherche de fichiers.
    '(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de
    'fichiers, sinon le temps de traitement va être très long).
    Dossier = "C:\Documents and Settings\mimi\dossier"
 
    'Appelle la procédure de recherche des fichiers
    ListeFichiers Dossier
 
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:E").AutoFit
    MsgBox "Terminé"
End Sub
 
 
 
Sub ListeFichiers(Repertoire As String)
    '
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
        'Cliquez sur le bouton OK pour valider.
 
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
    'Récupère le numéro de la dernière ligne vide dans la colonne A.
    i = Range("A65536").End(xlUp).Row + 1
 
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        'Inscrit le nom du fichier dans la cellule
        Cells(i, 1) = FileItem.Name
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
            Address:=FileItem.ParentFolder & "\" & FileItem.Name
        'Indique la date de création
        Cells(i, 2) = FileItem.DateCreated
        'Indique la date de dernier acces
        Cells(i, 3) = FileItem.DateLastAccessed
        'Indique la date de dernière modification
        Cells(i, 4) = FileItem.DateLastModified
        'Nom du répertoire
        Cells(i, 5) = FileItem.ParentFolder
 
        i = i + 1
    Next FileItem
 
 
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder
 
End Sub

17/10/2018, 14h56
Menhir

Citation:

Envoyé par jft60

comment puis-je extraire les données par exemple d'une cellule dans chaque fichier.

En ouvrant chaque fichier avec un Workbooks.Open et en oubliant pas de le refermer avec un Close après avoir transféré les données.
Inspire-toi du code que tu as donné dans ton premier message.