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
| Sub btnImport()
Dim NbFichiers As Integer
' Dossier des classeurs à traiter
Const Dossier As String = "Z:\Stage - Adeline\Aupal\Dossier"
'à modifier pour pointer sur le dossier désiré'
End Sub
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 transfert"
Range("C3").Formula = "Date de Facture"
Range("D3").Formula = "Nom ou Raison sociale"
Range("E3").Formula = "Adresse"
Range("F3").Formula = "Ville"
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 = ExecuteExcelMacro(argument)
End Function
Sub btnImport_QuandClic()
Dim Debut As Variant
Dim NumeroLigne As Integer, i As Integer
Dim NomFichier As String
Dim NomFeuille As String
Const Dossier As String = "Z:\Stage - Adeline\Aupal\Dossier"
' 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).Formula = ExtraireValeur(Dossier, NomFichier, NomFeuille, "C7")
Cells(NumeroLigne, 5).Formula = ExtraireValeur(Dossier, NomFichier, NomFeuille, "C8")
Cells(NumeroLigne, 6).Formula = ExtraireValeur(Dossier, NomFichier, NomFeuille, "C9")
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:D").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 Auto_Open()
' S'exécutera automatiquement à l'ouverture du fichier
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
Range("A1").Select
End Sub |
Extraire des données d'une même cellule, dans plusieurs fichiers
Répondre avec citation
. comme de toutes manieres, théoriquement, tu n'en a besoin qu'une fois, ça devrais faire l'affaire.
Envoyé par alsimbad
en n'oubliant pas d'indiquer qu'elle est la solution finale choisie 
mea culpa, milles excuses 
. c'était en quelque sorte un fichier à usage unique. tu aura mieux fait d'exposer ton problème au forum et d'écouter une solution plus moderne. de plus, je suis complètement autodidacte dans excel, sans formation informatique, donc je ne suis pas forcément le plus qualifié pour te répondre, et j'ai un peu perdu la main. désolé
Partager