Bonsoir à tous,
A tester avec le dernier fichier joint
Option Explicit
Sub test()
Dim a, e, v, w(), i As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
a = .Range("a1").CurrentRegion.Value
For i = 3 To UBound(a, 1)
If Not dico.exists(a(i, 1)) Then
Set dico(a(i, 1)) = CreateObject("Scripting.Dictionary")
End If
If Not dico(a(i, 1)).exists(a(i, 2)) Then
ReDim w(1 To 2)
Else
w = dico(a(i, 1))(a(i, 2))
End If
If Not IsEmpty(a(i, 3)) Then w(1) = w(1) + 1
If Not IsEmpty(a(i, 4)) Then w(2) = w(2) + 1
dico(a(i, 1))(a(i, 2)) = w
Next
For Each e In dico.keys
For Each v In dico(e).keys
If Not IsEmpty(dico(e)(v)(1)) Then dico(e).Remove v
Next
Next
For Each e In dico.keys
If dico(e).Count = 0 Then
dico.Remove e
End If
Next
With .Range("K5")
.CurrentRegion.Clear
If dico.Count > 0 Then
.Resize(dico.Count, 1).Value = Application.Transpose(dico.keys)
Else
MsgBox "Pas d'appels uniques vers l'agence 2"
End If
End With
End With
Set dico = Nothing
End Sub
klin89