Sub Comptage(w As Worksheet) 'macro paramétrée
Dim derlig&, t, d As Object, i&, x$, a(), n, j, p, y$, q, z$
Application.ScreenUpdating = False
w.Range("R2:U" & w.Rows.Count) = "" 'RAZ de la zone de restitution
If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
w.[A:P].Sort w.[A1], xlDescending, w.[B1], , xlAscending, Header:=xlYes 'tri
derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row + 1 'une ligne vide en plus
t = w.Range("A1:G" & derlig) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To derlig
x = t(i, 1) & t(i, 2)
Erase a: n = 0
For j = i To derlig
If t(j, 1) & t(j, 2) <> x Then
If n Then
tri a, 1, n 'tri croissant
For p = 1 To n - 1
y = "'" & a(p)
For q = p + 1 To n
z = y & "-" & a(q)
d(z) = d(z) + 1 'comptage des paires
Next q, p
End If
i = j - 1
Exit For
End If
If t(j, 7) <> "" Then
n = n + 1
ReDim Preserve a(1 To n)
a(n) = t(j, 7)
End If
Next j, i
If d.Count = 0 Then Exit Sub
'---restitution---
With w.[R2].Resize(d.Count, 4)
.Columns(1) = Application.Transpose(d.keys)
.Columns(2) = Application.Transpose(d.items)
.Columns(1).TextToColumns .Columns(3), xlDelimited, Other:=True, OtherChar:="-" 'commande Convertir
.Sort .Columns(2), xlDescending, .Columns(3), , xlAscending, .Columns(4), xlAscending, Header:=xlNo 'tri
.Columns(3).Resize(, 2) = ""
End With
End Sub
Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
