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
|
Sub Recapitulatif()
Dim Source As Worksheet
Dim Recap As Worksheet
Dim Donnees As New Collection
Dim Cellule As Range
Dim Donnee As String
Dim Element As Variant
' Récupération des données des onglets
' On itère sur toutes les feuilles du classeur
For Each Source In ThisWorkbook.Worksheets
' Si le nom commence par Res_, on ajoute les données à la collection
If Left(Source.Name, 4) = "Res_" Then
For Each Cellule In Source.Range("a2:a" & Source.Range("a65536").End(xlUp).Row)
' Concaténation des données
Donnee = Cellule & ";" & Cellule(1, 2) & ";" & Cellule(1, 3) & ";" & Cellule(1, 4)
' Ajout de l'élement dans la collection
Donnees.Add Donnee
Next Cellule
End If
Next Source
' Création de la liste dans l'onglet récapitulatif
Set Recap = Worksheets("Récap")
' Vidange de la feuille de récap
Recap.Range("a2:iv65536").ClearContents
' Itération sur les éléments de la collection
For Each Element In Donnees
' Renvoie la cellule en A si élément présent, sinon NOTHING
Set Cellule = CelluleRecap(Recap, Element)
' Si élément présent, on ajoute les valeurs aux valeurs présentes
If Not Cellule Is Nothing Then
Cellule(1, 2) = Cellule(1, 2) + Split(Element, ";")(1)
Cellule(1, 3) = Cellule(1, 3) + Split(Element, ";")(2)
Cellule(1, 4) = Cellule(1, 4) + Split(Element, ";")(3)
Else
' Sinon, on ajoute une ligne avec les valeurs
Set Cellule = Recap.Range("a65536").End(xlUp)(2)
Cellule(1, 1) = Split(Element, ";")(0)
Cellule(1, 2) = Split(Element, ";")(1)
Cellule(1, 3) = Split(Element, ";")(2)
Cellule(1, 4) = Split(Element, ";")(3)
End If
Next Element
End Sub
Function CelluleRecap(Feuille As Worksheet, ByVal Nom As String) As Range
' Si Nom est présent dans la colonne A de Feuille, renvoie la cellule en A
' Sinon, l'objet retourné est NOTHING
Dim Cellule As Range
For Each Cellule In Feuille.Range("a2:a" & Feuille.Range("a65536").End(xlUp).Row)
If Split(Nom, ";")(0) = Cellule.Value Then
Set CelluleRecap = Cellule
Exit For
End If
Next Cellule
End Function |
Partager