macro excel pour récupérer cellules

**touaine** · 04/05/2007, 19h02

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

**alsimbad** · 04/05/2007, 19h32

salut, je n'ai pas tout lu, mais a priori dans :

NomFichier = ShImport.Range("A" & NumeroLigne)

ShImport n'est pas du tout une variable, mais le nom d'une feuille de calcul, et plus exactement, il semble que ce soit celle a partir de laquelle tu lance ta macro d'import, et sur lequel le code inscrit le nom des fichier qu'il a trouvé dans dossiersource. donc, soit tu batise cette feuille, soit c'est le programme qui est sensé le faire a un momment, a toi de voir

**touaine** · 04/05/2007, 21h05

bon voila j'ai récupéré un fichier pour mes données mais j'ai encore un probleme d'execution au niveau du ExecuteExcel4Macro(argument).

je sais pas si ca vient de la version d'excel parce que dans mon excel d'import j'ai toutes les données que je voulais (nom de fichier, date de création, taille, repertoire...) Mais PAS la valeur...

si quelqu'un a une solution ca serait cool

merci

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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
'==================================================================================
'
'   Dans environnement VBA
'   Outils | Références COCHER Microsoft Scripting Runtime
'
'   Sinon VBScript téléchargeable à
'   http://msdn.microsoft.com/library/de...ist/webdev.asp
'
'==================================================================================

Option Explicit

Dim NbFichiers As Long
Dim DossierOk As String

'===============================================================================================
'   NomFichierRch   :   Fichier recherché, "*" si on les veut tous, "NCR*" si l'on ne veut que
'                       les fichiers débutant par NCR, voir aide en ligne sur opérateur LIKE
'                       ATTENTION sensible à la casse : minuscules/majuscules
'                       par exemple Classeur ‡ classeur
'
'   DossierRacine   :   "C:\...\Tst" dossier de départ pour la recherche des fichiers
'                       Dans Procédure btnImport_QuandClic modifer
'                           ListeFichiersDansDossier DossierOk, True
'                           en ListeFichiersDansDossier DossierOk, False
'                           si l'on ne veut pas de recherche dans les sous dossiers
'
'   NomFeuille      :   Si l'onglet des fichiers testés ne s'appelle pas "Feuil1"
'                       une erreur #REF! est incrite dans les cellules concernées
'                       de la feuille ShImport
'
'   TypeFichier     :   Type de fichiers que l'on traite, "XLS" pour les fichiers Excel
'                       Cela évitera des erreurs si le dossier contient par erreur ou hasard
'                       d'autres type de fichiers doc, pdf etc
'
'===============================================================================================

'   Pour TESTS sinon à Adapter par l'utilisateur a ses besoins
'
'.............................................................

'Const NomFichierRch = "Classeur*"
'Const NomFichierRch = "FF+COXX060#X*"
'Const NomFichierRch = "####_#######_###_P*"
'   0027_XXXXXXX_YYY_P
Const NomFichierRch = "test*"
Const DossierRacine As String = "C:\Documents and Settings\Antoine\Bureau\macro"
Const NomFeuille As String = "test*"
Const TypeFichier As String = "XLS"

'.............................................................

'Const NomFichierRch = "NCR*"
'Const DossierRacine As String = "C:\NCR\NCR Report"
'Const NomFeuille As String = "template"
'Const TypeFichier As String = "XLS"

'===============================================================================================
'               Ici l'on ne traite q'une valeur située en A1
'               Pour infos j'ai ajouté une autre cellule Z3
'               Donc si l'on doit ajouter d'autres cellules à lire il
'               faudra aller modifier les procedures et fonctions suivantes
'                   Entete
'                   ListeFichiersDansDossier
'                   btnImport_QuandClic
'
'===============================================================================================

Private Sub Entete()
    With ShImport
        .Cells.Clear
        .Range("A3").Formula = "Fichier"
        .Range("B3").Formula = "Dossier"
        .Range("C3").Formula = "Date Création"
        .Range("D3").Formula = "Taille"

        '   A1  Z3
        .Range("E3").Formula = "E2173"
        '.Range("E4").Formula = "Z3"
    End With
End Sub

Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim Extension As String
Dim r As Long, VerifNom As Boolean

    On Error GoTo erreurs
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)

    r = Range("A65536").End(xlUp).Row + 1

    For Each Fichier In DossierSource.Files
        Extension = UCase(FSO.GetExtensionName(Fichier))
        VerifNom = Fichier.Name Like NomFichierRch
        If Fichier.Name <> ThisWorkbook.Name Then
            If VerifNom Then
                If InStr(Fichier.Name, Chr(39)) > 0 Then Fichier.Name = Replace(Fichier.Name, Chr(39), "")
                If UCase(TypeFichier) = Extension Then
                    With ShImport
                        .Cells(r, 1).Formula = Fichier.Name
                        .Cells(r, 2).Formula = Fichier.ParentFolder
                        .Cells(r, 3).Formula = Fichier.DateCreated
                        .Cells(r, 4).Formula = Fichier.Size
                        NbFichiers = NbFichiers + 1
                        r = r + 1
                    End With
                    Application.StatusBar = "Lecture noms : " & r
                End If
            End If
        End If
    Next Fichier

    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
        Set SousDossier = Nothing
    End If

    ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C5"
    ' Si cellule Z3 remplacer la ligne ci-dessus par
    'ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C6"

    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
    Exit Sub

erreurs:
    Select Case Err.Number
        Case 76
            MsgBox "Dossier inexistant" & vbCrLf & "Modifier dans VBA le chemin" & vbCrLf & "Const Dossier = " & DossierRacine, vbOKOnly, "Dossier des Fichiers"
        Case Else
            MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
    End Select
End Sub

Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, _
                                ByVal Feuille As String, ByVal Cellule As String)
Dim argument As String
    argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(argument)
End Function

Private Sub btnImport_QuandClic()
Dim Debut As Variant
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
Dim NomDossier As String

    Debut = Time()
    Application.ScreenUpdating = False
    NbFichiers = 0
    NumeroLigne = 4

    Entete
    DossierOk = BackSlashDossier(DossierRacine)

    '   Recherche récursive ou non à partir de DossierRacine
    '   si recherche dans DossierRacine seulement
    '   remplacer ListeFichiersDansDossier DossierOk, True par
    '   ListeFichiersDansDossier DossierOk, False

    ListeFichiersDansDossier DossierOk, True

    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        NomDossier = BackSlashDossier(ShImport.Range("B" & NumeroLigne))

        With ShImport
            .Cells(NumeroLigne, 5) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A1")
            '.Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "Z3")
        End With
        NumeroLigne = NumeroLigne + 1
        Application.StatusBar = i & " / " & NbFichiers
    Next

    Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00")

    MepFinale

    Application.ScreenUpdating = True
End Sub

Private Function BackSlashDossier(ByVal TstDossier As String) As String
    If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
    BackSlashDossier = TstDossier
End Function

Private Sub MepFinale()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With

    Rows("3:3").Font.Bold = True
    Columns("C:D").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Columns("A:E").Columns.AutoFit
    DispoBoutons
    Range("A1").Select
End Sub

Public Sub DispoBoutons()
Dim t As Range
    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 Tri()
    Application.Goto Reference:="Zone_de_Tri"
    Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlNo
    Range("A1").Select
End Sub

macro excel pour récupérer cellules

Macros et VBA Excel

Discussions similaires

Partager

Partager