bonjour,
une proposition
Option Explicit
Sub aargh()
Dim dict As Object
Dim plageb As Range, re As Range
Dim dlb&, dla&, i&, j&, i1&, i2& 'long
Dim norme$, s$, fa$, pb$, a$ 'string
Dim k, it 'variant
Set dict = CreateObject("scripting.dictionary")
With Sheets("sheet1")
dlb = .Cells(Rows.Count, 1).End(xlUp).Row
Set plageb = .Range("B9:C" & dlb) 'plage des normes produits B
dla = .Cells(Rows.Count, 5).End(xlUp).Row
For i = 9 To dla ' pour chaque produit A
' on compte les normes du produit A trouvées dans les produits B
For j = 6 To 11 'pour chaque norme, de la colonne 6(F) à la colonne 11 (K)
norme = Trim(.Cells(i, j))
If norme = "" Then Exit For
Set re = plageb.Find(norme, lookat:=xlPart) 'on recherche les produits qui ont cette norme
If Not re Is Nothing Then 's'il y a au moins un produit
fa = re.Address
Do
pb = .Cells(re.Row, 1)
dict(pb) = dict(pb) + 1 ' on ajoute 1 au compteur du produit b trouvé
Set re = plageb.FindNext(re)
Loop Until re.Address = fa
End If
Next j
k = dict.keys
it = dict.items
' on trie les produits B sur base du nombre de normes trouvées (du nombre le plus grand au plus petit)
For i1 = LBound(k) To UBound(k) - 1
For i2 = i1 + 1 To UBound(k)
If it(i1) < it(i2) Then a = it(i1): it(i1) = it(i2): it(i2) = a: a = k(i1): k(i1) = k(i2): k(i2) = a
Next i2
Next i1
' on affiche le résultat pour le produit A
s = ""
For i1 = LBound(k) To UBound(k)
s = s & k(i1) & "(" & it(i1) & "),"
Next i1
If s <> "" Then s = Left(s, Len(s) - 1)
.Cells(i, "L") = s
'on réinitialise les compteurs de normes par produit
dict.RemoveAll
Next i
End With
End Sub