Petit souci de définition de variable

**ArnaudMO** · 12/05/2011, 13h26

Bonjour,
J'ai trouvé sur internet le code suivant qui permet d'aller récuprer les mêmes case d'un fichier excel sur tout les classeurs d'un dossier indiqué. Mon problème est que je crér un fichier test, deux onglets ( Import et ShImport) je met le code ci dessous, je l'execute et la j'ai une erreur : variable non défini à chaque "ShImport". Quelqu'un ici pourrait'il me dire ce que je fais de mal ou si je dois définir ma variable d'une manière particulière ?

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
'=========================================================================================================
' Créer un classeur avec une feuille vierge que l'on nommera
'     Import ( Nom sans importance )    : propriété Name sous VBE
'     ShImport                          : propriété (Name) sous VBE
'
' Dans environnement VBE
'       Recopier l'ensemble du code ci dessous dans un module
'       Outils | Références Cocher Microsoft Scripting Runtime
'
' Un bouton est à créer sur la feuille "Import"
'    il faut le nommer btnImport et lui affecter la procédure 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:\Documents and Settings\A352721\Bureau\Testt\"
'   On suppose que tous les fichiers contiennent les données dans Feuil1
'       Si un onglet ne s'appelle pas NomFeuille
'       une erreur #REF! est inscrite dans les cellules concernées
Const NomFeuille As String = "Feuil1"
 
Private Sub Entete()
    With ShImport
        ' Tout effacer
        .Cells.Clear
        .Range("A3").Formula = "Fichier"
        ' A tout hasard cela peut être interessant
        ' d'avoir ces infos sur les fichiers
        .Range("B3") = "Date de Création"
        .Range("C3") = "Date Dernière Modification"
 
        'A10 D10 H10 J10 D54 H54
        .Range("D3") = "A10"
        .Range("E3") = "D10"
        .Range("F3") = "H10"
        .Range("G3") = "J10"
        .Range("H3") = "D54"
        .Range("I3") = "H54"
    End With
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)
 
    NbFichiers = 0
    r = ShImport.Range("A65536").End(xlUp).Row + 1
 
    ' Balayer le dossier et extraire le nom des fichiers
    For Each Fichier In DossierSource.Files
        With ShImport
            .Cells(r, 1) = Fichier.Name
            .Cells(r, 2) = Fichier.DateCreated
            .Cells(r, 3) = Fichier.DateLastModified
        End With
        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(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)
Dim Argument As String
    Fichier = Replace(Fichier, "'", "''")
    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
Dim DDate As String
Dim DossierOk As String
 
    ' Par curiosité
    Debut = Time()
    Application.ScreenUpdating = False
        Entete
        DossierOk = Dossier
        ' Pour éviter le drame du copier/coller ....
        If Right(DossierOk, 1) <> "\" Then DossierOk = DossierOk & "\"
 
        ListeFichiersDans DossierOk
 
        ' 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)
 
            With ShImport
                .Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "A10")
                .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D10")
                .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H10")
                .Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "J10")
                .Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D54")
                .Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "H54")
 
                '  Si Dates à extraire mal formatées
                '  DDate = ExtraireValeur(DossierOk , NomFichier, NomFeuille, "Cxy" )
                '  If IsDate(DDate) Then .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
 
                '  Sinon
                '  .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
 
            End With
 
            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
 
       With ShImport
           .Rows("3:3").Font.Bold = True
           .Columns("B:C").Select
           With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
           End With
           .Columns("A:I").Columns.AutoFit
           .Range("A1").Select
      End With
    Application.ScreenUpdating = True
End Sub
 
Private 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 Workbook_Open()
    DispoBoutons
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    ShImport.Range("A1").Select
End Sub