XL 2019 formule simple

Sub Frequence_max_2_numeros()
Dim dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, x$, maxi&, a, b, resu$(), n&
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 1
        If s(j) <> "" Then
            For k = j + 1 To ub
                If s(k) <> "" Then
                    x = s(j) & "-" & s(k)
                    d(x) = d(x) + 1 'comptage
                    dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 2 numéros : " & maxi
End Sub

Sub Frequence_max_3_numeros()
Dim dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, m%, x$, maxi&, a, b, resu$(), n&
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 2
        If s(j) <> "" Then
            For k = j + 1 To ub - 1
                If s(k) <> "" Then
                    For m = k + 1 To ub
                        If s(m) <> "" Then
                            x = s(j) & "-" & s(k) & "-" & s(m)
                            d(x) = d(x) + 1 'comptage
                            dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                        End If
                    Next m
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 3 numéros : " & maxi
End Sub

Sub Frequence_max_2_numeros()
Dim numcible$, dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, x$, y$, maxi&, a, b, resu$(), n&
numcible = "*-" & IIf([J11] = "", "*", [J11]) & "-*" 'n° cible encadré + caractère générique *
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 1
        If s(j) <> "" Then
            For k = j + 1 To ub
                If s(k) <> "" Then
                    x = s(j) & "-" & s(k)
                    y = "-" & x & "-" 'texte encadré
                    If y Like numcible Then
                        d(x) = d(x) + 1 'comptage
                        dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                    End If
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 2 numéros : " & maxi
End Sub

Sub Frequence_max_3_numeros()
Dim numcible$, dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, m%, x$, y$, maxi&, a, b, resu$(), n&
numcible = "*-" & IIf([J11] = "", "*", [J11]) & "-*"  'n° cible encadré + caractère générique *
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 2
        If s(j) <> "" Then
            For k = j + 1 To ub - 1
                If s(k) <> "" Then
                    For m = k + 1 To ub
                        If s(m) <> "" Then
                            x = s(j) & "-" & s(k) & "-" & s(m)
                            y = "-" & x & "-" 'texte encadré
                            If y Like numcible Then
                                d(x) = d(x) + 1 'comptage
                                dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                            End If
                        End If
                    Next m
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 3 numéros : " & maxi
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Recherche As Range, NC As Range, P As Range, Dates As Range, Complement As Range, R As Range, c As Range, Q As Range
Set Recherche = [T11:X11]
Set NC = [Y11] 'recherche du numéro complémentaire
Set P = [E:I]
Set Dates = [D:D]
Set Complement = [J:J]
If Intersect(Target, Union(Recherche, NC)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'mode de calcul manuel
On Error Resume Next 'si aucune SpecialCell
'Recherche.Offset(1).Resize(Rows.Count - Recherche.Row, Recherche.Columns.Count + 2).Delete xlUp 'RAZ
Recherche.Offset(1).Resize(Rows.Count - Recherche.Row, Recherche.Columns.Count + 2).ClearContents 'RAZ

If NC = "" Then
    Set R = P
Else
    Complement.Replace NC, "#N/A", xlWhole
    Set R = Complement.SpecialCells(xlCellTypeConstants, 16)
    If R Is Nothing Then GoTo 1
    R = NC
    Set R = Intersect(R.EntireRow, P)
End If
For Each c In Recherche
    If c <> "" Then
        P.Replace c, "#N/A", xlWhole
        Set Q = Nothing
        Set Q = P.SpecialCells(xlCellTypeConstants, 16)
        If Q Is Nothing Then GoTo 1
        Q = c
        Set Q = Intersect(Q.EntireRow, P)
        Set R = Intersect(Q, R)
    End If
Next
'---résultat---
R.Copy Recherche(2, 1)
Intersect(R.EntireRow, Complement).Copy NC(2)
Intersect(R.EntireRow, Dates).Copy NC(2, 2)
1 Application.Calculation = xlCalculationAutomatic 'rétablit le calcul automatique
End Sub