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