Bonsoir Grégory, Kiki, bonsoir le forum,
Ce code à placer dans le classeur récapitulatif des données qui devient donc .xlsm :
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
| Sub Macro5()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Object 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Object 'déclare la variable OD (Onglet Source)
Dim BE As String 'déclare la variable BE (Boîte d'Entrée)
Dim SF As Object 'déclare la variable SF (Système de Fichiers)
Dim D As Object 'déclare la variable D (Dossier)
Dim FS As Object 'déclare la variable FS (FichierS)
Dim F As Object 'déclare la variable F (Fichier)
Dim PA As String 'déclare la variable PA (Première Adresse)
Dim LI As Integer 'déclare la variable LI (LIgne)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Set CD = ThisWorkbook 'définit le classeur de destination CD
Set OD = CD.Sheets("données") 'définit l'onglet de destination OD
Set SF = CreateObject("Scripting.FileSystemObject") 'définit la variable SF
Set D = SF.GetFolder(CD.Path) 'définit la dossier D
Set FS = D.Files 'définit l'ensemble FS des fichiers de D
If FS.Count > 1 Then 'condition : si D possède au moinr un fichier
BE = InputBox("Argument à rechercher", "RECHERCHE") 'définit la boîte d'entrée BE
If BE = "" Then Exit Sub 'si BE est vide ou boton "Annuler", sort de la procédure
For Each F In FS 'boucle sur tous les fichier F de D
If Left(F.Name, 15) = "Taux de service" Then 'condition 2 : si le nom du fichier commence par "Taux de service"
Workbooks.Open (F) 'ouvre le fichier
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("Tous") 'définit l'onglet source OS
Set R = OS.Cells.Find(BE, , xlValues, xlWhole) 'définit la recherche R
If Not R Is Nothing Then 'consition 3 : si il existe au moins une ocurrence trouvée
PA = R.Address 'définit l'adresse PA de la première occurrence trouvée
LI = 0 'définit la ligne li
Do 'exécute
'définit la cellule de destination DEST (A2 si A2 est vide, sinon la première cellule vide de la colonne A de l'onglet OD)
Set DEST = IIf(OD.Range("A2").Value = "", OD.Range("A2"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
'copie la ligne de l'occurence trouvée et la colle dans DEST
'si la ligne de l'occurrence trouvée est différente de la ligne LI
If R.Row <> LI Then Rows(R.Row).Copy DEST
LI = R.Row 'définit la ligne LI
Set R = OS.Cells.FindNext(R) 'redéfinit la recherche R (occurrence suivante)
Loop While Not R Is Nothing And R.Address <> PA 'boucle tant qu'il existe de nouvelle occurrences ailleurs qu'en PA
End If 'fin de la condition 3
CS.Close SaveChanges:=False 'ferme le classeur source sans enregistrer
End If 'fin de la condition 2
Next F 'prochaine fichier de la boucle
End If 'fin de la condition 1
End Sub |
Ne fonctionne qui si le classeur récapitulatif des données.xlsm se trouve lui aussi dans le dossier indicateur sinon, remplacer la ligne
Set D = SF.GetFolder(CD.Path) 'définit la dossier D
par :
Set D = SF.GetFolder(Chemin_complet_du_dossier_indicateur) 'définit la dossier D
Partager