Concaténation de données associées à une valeur unique

Bonjour à tous,

C'est mon premier post ici, j'espère que j'arriverais a être suffisamment claire

J'ai une très grosse base de données dans lequel j'ai des informations sur des coloris, de cette base j'extrait une toute petite fraction qui m'intéresse (N°, Utilisation, Nom du coloris, Sites où on les retrouvent et leur Niveau de sécurisation). Certains coloris sont parfois présents sur plusieurs sites et peuvent avoir des niveau de sécurisation différents. Ils peuvent être également présents 2 fois sur le même sites quand ils sont évalués sur des support différents.

Je cherche à concaténer de manière à n'avoir qu'une ligne par coloris, les sites regroupés dans une seule cellule (séparés par une virgule) ET les niveaux de sécurisation regroupés dans une autre. Le tout en évitant les répétitions dans les cellules concaténées.

Idéalement, j'aimerais également n'avoir que l'informations Sécurisé ou Non Sécurisé dans le cas ou un coloris ressort aussi A Tester

Ex : BORDEAUX B = Sécurisé, A Tester, A Tester --> BORDEAUX B = Sécurisé)

J'ai récupéré et adapté un code qui ne me permet de concaténer les informations que d'une seule colonne à la fois... J'aimerais juste pouvoir appliquer ce même principe aux deux colonnes (Sites et Sécurisation) en évitant les répétitions.

Voilà le code que j'utilise pour l'instant :

Sub ConcatenateCellsIfSameValues()
'UpdatebyExtendoffice20180201
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xRgKey As Range
    Dim xRgVal As Range
    Dim xStr As String
    Dim xDic As New Dictionary
    On Error Resume Next
    Set xRg = Application.InputBox("Selectioner la plage de données", Selection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xRgKey = Application.InputBox("Selectionner la colonne de référence", xRg.Columns(1).Address, , , , , 8)
    If xRgKey Is Nothing Then
        MsgBox "La colonne de référence ne peut être vide", vbInformation
    End If
    Set xRgVal = xRg(1).Offset(, 1).Resize(xRg.Rows.Count, xRg.Columns.Count - 1)
    For I = 1 To xRgKey.Count
        If I > xRgKey.Count Then Exit For
        xStr = ""
        For J = 1 To xRgVal.Columns.Count
            xStr = xStr & " " & xRgVal(I, J)
        Next
        If xDic.Exists(xRgKey(I).Text) Then
            xDic(xRgKey(I).Text) = xDic(xRgKey(I).Text) & xStr
            xRgKey(I).EntireRow.Delete
            I = I - 1
       Else
            xDic.Add xRgKey(I).Text, xStr
        End If
    Next
    For I = 1 To xRgVal.Count
        xRgVal(I).Value = xDic(xRgKey(I).Text)
    Next
End Sub

Je ne suis pas particulièrement attachée à ce code donc si quelqu'un a une façon autre ou simplifié d'y arriver, je suis tout à fait preneuse !

Je vous joint également un tableau simplifiés représentatif :

J'espère ne pas trop en demander et avoir été suffisamment claire dans mon explication et ma requête, n'hésitez pas s'il vous faut des infos supplémentaires

Bonne journée à tous,

Bonjour,

A tester, une solution avec des formules :

Daniel