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
|
Option Explicit
Public Sub Importer()
Dim oFSO As FileSystemObject 'objet de gestion de fichiers
Dim oShR As Worksheet 'onglet résultat
Dim sRep As String 'chemin du répertoire principal
Dim oRep As Folder 'objet répertoire
Dim oFic As File 'objet fichier
Dim oWBx As Workbook 'classeur excel à importer (plusieurs)
Dim oShx As Worksheet 'onglet du classseur à importer
Dim iDerLig As Long 'dernière ligne
Dim iColEcr As Integer 'colonne d'écriture
Dim iAvanc As Integer 'avancement
'sélection du répertoire à importer
sRep = ChoixDossier()
'si l'utilisateur annule la recherche, on arrête
If sRep = "" Then
Exit Sub
End If
'instanciation des objets
Set oFSO = New FileSystemObject 'objet de gestion de fichier
Set oRep = oFSO.GetFolder(sRep) 'objet répertoire
Set oShR = Workbooks("ConcatenerDonnees-v1.xlsm").Worksheets("Resultat") 'onglet résultat
'efface le résultat
oShR.Cells.ClearContents
iColEcr = 1 'colonne d'écriture dans l'onglet résultat (incrémentée pour chaque nouveau fichier importé)
iAvanc = 0 'pour affichage de l'avancement (barre de progression)
Application.ScreenUpdating = False 'bloque la mise à jour de l'affichage (accélère le traitement)
'parcours de tous les fichiers du répertoire
For Each oFic In oRep.Files
'barre de progression
''modProgress.ShowProgress iAvanc, oRep.Files.Count
'prend en compte tous les fichiers avec un nom "[Diagramme ] ..... [° collecteur.xlsx]"
If oFic.Name Like "diagramme * ° collecteur.xlsx" Then
'ouverture du fichier
Set oWBx = Workbooks.Open(oFic.Path, , True)
'premier onglet du fichier
Set oShx = oWBx.Worksheets(1)
'dernière ligne du fichier
iDerLig = oShx.Range("I" & Rows.Count).End(xlUp).Row
'nom du fichier
oShR.Cells(1, iColEcr).Value = oWBx.Name
'copie
oShx.Range("I4:I" & iDerLig).Copy
'colle
oShR.Cells(2, iColEcr).PasteSpecial xlPasteAll
'vide presse-papier
Application.CutCopyMode = False
'désinstanciation de l'objet
Set oShx = Nothing
'fermeture du fichier
oWBx.Close
'désinstanciation de l'objet
Set oWBx = Nothing
'pour le prochain fichier, on écrira dans la colonne suivante
iColEcr = iColEcr + 1
End If
'avancement
iAvanc = iAvanc + 1
Next oFic
'mise à jour de l'affichage
Application.ScreenUpdating = True
'désinstanciation des objets
Set oShR = Nothing
Set oRep = Nothing
Set oFSO = Nothing
End Sub
'sélection d'un dossier
Private Function ChoixDossier() As String
With Application.FileDialog(msoFileDialogFolderPicker)
'fichier par défaut
.InitialFileName = ActiveWorkbook.Path & "\"
.Show
If .SelectedItems.Count > 0 Then
'si l'utilisateur sélectionne un fichier, renvoie ce fichier
ChoixDossier = .SelectedItems(1)
Else
'si l'utilisateur annule le choix, renvoie ""
ChoixDossier = ""
End If
End With
End Function |
copier coller liste de fichier
Répondre avec citation
) dont les paroles s'accordent avec 
Envoyé par max36000
Partager