Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim t, d As Object, i&, x$, y$, z$
If Target.Address <> "$A$1" Then Exit Sub
Cancel = True
t = Intersect(Target.Resize(, 2).EntireColumn, Me.UsedRange.EntireRow)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
x = Application.Trim(t(i, 1)) 'SUPPRESPACE
y = Application.Trim(t(i, 2)) 'SUPPRESPACE
z = x & Chr(1) & y
If x & y <> "" Then d(z) = d(z) + 1 'comptage
Next
If d.Count = 0 Then Exit Sub 'sécurité, tableau vide
'---restitution et conversion des données---
Application.ScreenUpdating = False
With [D1].Resize(d.Count) 'D1 à adapter
.Resize(, 3).EntireColumn = Empty 'RAZ
.Value = Application.Transpose(d.keys)
.TextToColumns .Cells(1), xlDelimited, Space:=False, Other:=True, OtherChar:=Chr(1) 'commande Convertir
.Offset(, 2) = Application.Transpose(d.items)
.Cells(1, 3) = "Nombre"
.Resize(, 3).Sort .Cells(1), xlAscending, , .Cells(1, 2), xlAscending, Header:=xlYes 'tri
End With
End Sub