voila je cherche a lier Lit les mêmes cellules d'une feuille nommée F dans n fichiers XL ( sans les ouvrir ) . j'ai trouvé ce code mais j'ai un problème avec la variable ShImport en gras ci dessous qui ne veut pas s'executer. DOnc si quelqu'un pouvait m'aider c'est assez urgent...
Merci d'avance

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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
'=================================================================
' Créer un classeur avec une feuille vierge que l'on nommera par exemple Import
'
' Dans environnement VBA  
'  Menu Insertion Module
'  Outils/Références cocher Microsoft Scripting Runtime
'  Recopier l'ensemble du code ci dessous
'
' Renommer la feuille Import dans VBA sous le nom ShImport
'
' Un bouton est à créer sur la feuille Import
'    il faut le nommé btnImport et lui affecter la procedure btnImport_QuandClic
'
' Const Dossier As String = "C:\Transfert\Essais\" à modifier pour pointer sur
'  le dossier désiré
'
'=================================================================
 
Option Explicit
Dim NbFichiers As Integer
'   Dossier des classeurs à traiter
Const Dossier As String = "C:\Transfert\Essais\"
 
Private Sub Entete()
    '   Tout effacer
    Cells.Clear
    Range("A3" ).Formula = "Fichier"
    ' A tout hasard cela peut être interessant
    ' d'avoir ces infos sur les fichiers
    Range("B3" ).Formula = "Date de Création"
    Range("C3" ).Formula = "Date Dernière Modification"
     
    'A10 D10 H10 J10 D54 H54
    Range("D3" ).Formula = "A10"
    Range("E3" ).Formula = "D10"
    Range("F3" ).Formula = "H10"
    Range("G3" ).Formula = "J10"
    Range("H3" ).Formula = "D54"
    Range("I3" ).Formula = "H54"
End Sub
 
Private Sub ListeFichiersDans(NomDossierSource As String)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder
Dim fichier As Scripting.file
Dim r As Long
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
     
    '   Mettre le compteur à 0
    NbFichiers = 0
    '   Récupérer en haut la 1ere ligne vierge
    r = Range("A65536" ).End(xlUp).Row + 1
     
    ' Balayer le dossier et extraire le nom des fichiers
    For Each fichier In DossierSource.Files
        Cells(r, 1).Formula = fichier.Name
        Cells(r, 2).Formula = fichier.DateCreated
        Cells(r, 3).Formula = fichier.DateLastModified
        NbFichiers = NbFichiers + 1
        r = r + 1
    Next fichier
     
    Set fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
'   Permet de lire une valeur dans un fichier Excel fermé
Private Function ExtraireValeur(Dossier, fichier, feuille, Cellule)
Dim argument As String
    argument = "'" & Dossier & "[" & fichier & "]" & feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(argument)
End Function
 
Sub btnImport_QuandClic()
Dim Debut As Variant
Dim NumeroLigne As Integer, i As Integer
Dim NomFichier As String
'   On suppose que tous les fichiers contiennent
'   les données dans Feuil1
Const NomFeuille As String = "Feuil1"
 
    ' Par curiosité
    Debut = Time()
    Application.ScreenUpdating = False
        Entete
        ListeFichiersDans Dossier
         
        ' Si un onglet de NomFichier ne s'appelle pas NomFeuille
        ' une erreur #REF! est incrite dans les cellules concernées
         
        ' On démarre à cette ligne
        NumeroLigne = 4
        For i = 1 To NbFichiers
            NomFichier = ShImport.Range("A" & NumeroLigne)
 
            Cells(NumeroLigne, 4) = ExtraireValeur(Dossier, NomFichier, NomFeuille, "A10" )
            Cells(NumeroLigne, 5) = ExtraireValeur(Dossier, NomFichier, NomFeuille, "D10" )
            Cells(NumeroLigne, 6) = ExtraireValeur(Dossier, NomFichier, NomFeuille, "H10" )
            Cells(NumeroLigne, 7) = ExtraireValeur(Dossier, NomFichier, NomFeuille, "J10" )
            Cells(NumeroLigne, 8) = ExtraireValeur(Dossier, NomFichier, NomFeuille, "D54" )
            Cells(NumeroLigne, 9) = ExtraireValeur(Dossier, NomFichier, NomFeuille, "H54" )
             
            NumeroLigne = NumeroLigne + 1
            Application.StatusBar = i & " / " & NbFichiers
        Next
         
        Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
     
        ' Revenir en haut à gauche
        With ActiveWindow
            .ScrollRow = 1
            .ScrollColumn = 1
        End With
         
        Rows("3:3" ).Font.Bold = True
        Columns("B:" ).Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
        End With
        Columns("A:I" ).Columns.AutoFit
        Range("A1" ).Select
     
    '   Rafraichier l'écran à la fin du traitement
    Application.ScreenUpdating = True
End Sub
 
Private Sub DispoBoutons()
Dim t As Range
    ' Positionner et cadrer le bouton
    With ShImport
        .Activate
        .Rows(1).RowHeight = 12.75
        .Rows(2).RowHeight = 12.75
         
        Set t = .Cells(1, 3)
        With .Buttons("btnImport" )
            .Left = t.Left + 3
            .Top = t.Top + 5
            .Width = t.Width - 6
            .Height = Rows(1).RowHeight + Rows(2).RowHeight - 8
        End With
    End With
End Sub
 
Private Sub Auto_Open()
    ' S'exécutera automatiquement à l'ouverture du fichier
    DispoBoutons
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    Range("A1" ).Select
End Sub