Bonjour Alessandro
Voi si cela te convient
Attention les 'agente' doivent etre conservés sous les N° 1 a 20
Edit:Salut FredO0
Dim tab1
Sub toto()
t = Timer
Set tab1 = CreateObject("scripting.dictionary")
l = 2
com = Trim(Cells(2, 11))
While Cells(l, 1) <> ""
If Cells(l, 2) > agence_max Then agence_max = Cells(l, 2) ' recupere le nombre d'agence
If Trim(Cells(l, 1)) = com Then
agence = "A" & Cells(l, 2)
If tab1.exists(agence) Then
tab1(agence) = tab1(agence) + 1
Else
tab1(agence) = 1
End If
End If
l = l + 1
Wend
'ecriture resultat
l = 1
c = 14
Range(Cells(2, 14), Cells(1000, 15)).ClearComments
For b = 1 To agence_max
'For Each agence In tab1
l = b + 1
agence = "A" & b
If tab1.exists(agence) Then
Cells(l, c) = b
Cells(l, c + 1) = tab1(agence)
Else
Cells(l, c) = b
Cells(l, c + 1) = 0
End If
Next
MsgBox Round(Timer - t, 2) & " s"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$K$2" Then toto
end sub
Dim tab1
Dim tab2
Sub toto()
t = Timer
Set tab1 = CreateObject("scripting.dictionary")
Set tab2 = CreateObject("scripting.dictionary")
l = 2
com = Trim(Cells(2, 11))
While Cells(l, 1) <> ""
If Cells(l, 2) > agence_max Then agence_max = Cells(l, 2) ' recupere le nombre d'agence
If Trim(Cells(l, 1)) = com Then
agence = "A" & Cells(l, 2)
cle2 = Cells(l, 2) & "_" & Cells(l, 3)
If tab2.exists(cle2) = False Then
If tab1.exists(agence) Then
tab1(agence) = tab1(agence) + 1
Else
tab1(agence) = 1
End If
End If
tab2(cle2) = 1
End If
l = l + 1
Wend
'ecriture resultat
l = 1
c = 14
Range(Cells(2, 14), Cells(1000, 15)).ClearComments
For b = 1 To agence_max
'For Each agence In tab1
l = b + 1
agence = "A" & b
If tab1.exists(agence) Then
Cells(l, c) = b
Cells(l, c + 1) = tab1(agence)
Else
Cells(l, c) = b
Cells(l, c + 1) = 0
End If
Next
MsgBox Round(Timer - t, 2) & " s"
End Sub