[XL-2007] Récupérer des données de plusieurs classeurs fermés [Résolu]

[hdisnice]

Bonjour,

J'ai plusieurs fichiers excel formés de la même façon.

cad la cellule A1 par exemple sera toujours le même type d'information (nom de l'entreprise)

J'aimerai savoir si il était possible via bouton VBA sur un fichier externe de récupérer certaines cellules (genre A1) de mes 8 fichiers mais sachant aussi qu'il y a plusieurs onglets dans chaque fichier ?

et me mettre dans mon nouveau fichier en colonne A les informations A1 et en B le nom du fichier (avec lien hypertext sur le fichier et onglet si possible...)

D'avance merci.

[kiki29]

Salut, voir http://silkyroad.developpez.com/VBA/ClasseursFermes/ ainsi que
http://excel.developpez.com/faq/?pag...steFeuillesADO et http://www.developpez.net/forums/d20...feuille-excel/

[ZebreLoup]

Tu ne veux absolument pas les ouvrir pendant ton code ? Les solutions proposées par kiki29 sont très bien, pas pas évidente si tu n'es pas à l'aise avec le VBA, la notion de base de données...
Si c'est juste un problème d'affichage tu peux ouvrir un Excel en arrière plan.

Ensuite regarde les tutos de base de VBA sur les objets Workbooks, Worksheets...

[hdisnice]

Je peux les ouvrir aucun problème.

Je vais regarder vos exemples, mais j'utilise pas de base access je sais pas si c'est nécessaire dans vos exemples.

Merci

[ZebreLoup]

Voici un petit code pour exemple qui doit faire ce que tu veux. C'est à adapter bien sûr. Et tu peux aussi rajouter

Code :

1
2
3
Application.ScreenUpdating = False
'Traitements...
Application.ScreenUpdating = True

Si tu ne veux pas que les mises à jour soient visibles

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
Option Explicit
 
Public Sub RecupererDonnes()
    'En imaginant que les chemins des fichiers sont dans la feuil2 et qu'on veut copier sur la feuil1
    Dim rg As Range
    Set rg = Worksheets("Feuil2").Range("A1:A8")
 
    Dim c As Range
    Dim ligne As Integer
    ligne = 1
 
    Worksheets("Feuil1").Activate
 
    For Each c In rg.Cells
        RecupererUnClasseur c.Value, ligne
        ligne = ligne + 1
    Next c
End Sub
 
Private Sub RecupererUnClasseur(ByVal cheminFichier As String, ByRef ligne As Integer)
    Dim wb As Workbook
    Dim ws As Worksheet
 
    'On essaie d'ouvrir le fichier
    On Error Resume Next
    Set wb = Workbooks.Open(cheminFichier)
    If Err.Number <> 0 Then Exit Sub 'Si le fichier est introuvable, on le passe
    On Error GoTo 0
 
    For Each ws In wb.Worksheets
        ActiveSheet.Cells(ligne, 1).Value = ws.Range("A1")
        ActiveSheet.Cells(ligne, 2).Value = wb.Name
        ActiveSheet.Cells(ligne, 3).Value = ws.Name
        ligne = ligne + 1
    Next ws
 
    wb.Close
End Sub

[kiki29]

Salut, un pot-pourri des liens cités plus haut, que j'ai ressorti des décombres
Affecter un bouton à SelDossier

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
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
 
'   Cocher références Microsoft ActiveX Data Objects 2.x Library
'                     Microsoft ADO Ext 2.x for DLL and Security
'                     Microsoft Scripting Runtime
 
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim NbFichiers As Long
Dim NomFichierRch As String
Dim TabNoms() As String
 
Private Function BackSlashDossier(ByVal TstDossier As String) As String
    If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
    BackSlashDossier = TstDossier
End Function
 
Private Sub Entete()
    With ShImport
        .Cells.Clear
        .Range("A3") = "Fichier"
        .Range("B3") = "Dossier"
        .Range("C3") = "Date Création"
        .Range("D3") = "Taille"
        .Range("E3") = "Feuille"
        .Range("F3") = "A3"
    End With
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 Import(sDossier As String)
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
Dim NomDossier As String
Dim NomFeuille As String
 
    QueryPerformanceCounter Dep
    Application.ScreenUpdating = False
 
    NbFichiers = 0
    NumeroLigne = 4
    NomFichierRch = "*.xls"
 
    Entete
    sDossier = BackSlashDossier(sDossier)
    ListeFichiersDansDossier sDossier, True
 
    For i = 1 To NbFichiers
        With ShImport
            NomFichier = .Range("A" & NumeroLigne)
            NomDossier = BackSlashDossier(.Range("B" & NumeroLigne))
            NomFeuille = .Range("E" & NumeroLigne)
            .Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A3")
        End With
        NumeroLigne = NumeroLigne + 1
        Application.StatusBar = i & " / " & NbFichiers
    Next i
 
    Mep
 
    QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
    With Application
        .StatusBar = "Terminé : " & Format(((Fin - Dep) / Freq), "0.00 s")
        .ScreenUpdating = True
    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 r As Long, VerifNom As Boolean
 
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    r = ShImport.Range("A" & Rows.Count).End(xlUp).Row + 1
 
    For Each Fichier In DossierSource.Files
        VerifNom = UCase(Fichier.Name) Like UCase(NomFichierRch) And Fichier.Name <> ThisWorkbook.Name
        If VerifNom = True Then
            With ShImport
                .Cells(r, 1) = Fichier.Name
                .Cells(r, 2) = Fichier.ParentFolder
                .Cells(r, 3) = Fichier.DateCreated
                .Cells(r, 4) = Fichier.Size
 
                NomFeuilles .Cells(r, 2) & "\" & .Cells(r, 1)
                .Cells(r, 5) = TabNoms(0)
 
                NbFichiers = NbFichiers + 1
                r = r + 1
            End With
            Application.StatusBar = "Lecture Infos : " & r
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
    End If
 
    Set DossierSource = Nothing
    Set FSO = Nothing
 
End Sub
 
Private Sub Mep()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    With ShImport
        .Rows("3:3").Font.Bold = True
        .Columns("C:D").Select
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Tri
    With ShImport
        .Columns("A:E").Columns.AutoFit
        .Range("A1").Select
    End With
End Sub
 
Private Sub NomFeuilles(sNomFichier As String)
Dim Cn As ADODB.Connection
Dim Feuille As ADOX.Table
Dim Cat As ADOX.Catalog
Dim strConn As String, i As Long
 
    Erase TabNoms
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNomFichier & ";" & _
              "extended properties=""Excel 8.0;HDR=NO;IMEX=1"""
 
    Set Cat = CreateObject("ADOX.Catalog")
    Set Cn = CreateObject("ADODB.Connection")
 
    Cn.Open strConn
    Set Cat.ActiveConnection = Cn
    i = 0
    For Each Feuille In Cat.Tables
        ReDim Preserve TabNoms(i)
        TabNoms(i) = Replace(Feuille.Name, "$", "")
        TabNoms(i) = Replace(TabNoms(i), "'", "")
        i = i + 1
    Next Feuille
 
    Set Cat = Nothing
    Cn.Close
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Import .SelectedItems(1)
        End If
    End With
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    With ShImport
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A3:F" & LastRow).Sort Key1:=.Range("A4"), Order1:=xlAscending, _
                                      Key2:=.Range("B4"), Order2:=xlAscending, _
                                      Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
                                      Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
                                      DataOption2:=xlSortNormal
    End With
End Sub

[hdisnice]

Merci pour vos réponse, c'est sympa.

J'arrive a faire ce que je voulais avec le code de ZebreLoup.

Mais impossible avec celui de kiki29
Je dois pas faire les bonnes choses pourtant j'active bien les 3 choses dans 'outils' puis 'préférences'

encore merci.

[kiki29]

Salut, peut-être simplement l'usage de CodeName ? voir http://www.developpez.net/forums/d92...cel/vba-bases/