Me revoilà !
Après être passé de 5 minutes 34 secondes à 36 secondes sur un jeu test de 1000 individus, j'en suis maintenant à 5 secondes sur le même jeu et avec ma petite config i3 ... grâce à l'emploi de array et de dico faisant office de pseudo base de données avec clés secondaires (clé individu et clé zone).
Ouf !
Option Base 1
Sub Affecter()
Dim zone() As Variant
Dim data() As Variant
[debut] = Now
zone = [Tzones].Value
Set nb = CreateObject("Scripting.Dictionary") ' effectif par zone
For i = 1 To UBound(zone)
nb(zone(i, 1)) = zone(i, 2)
Next
Sheets("Data").ListObjects(1).Sort.Apply
data = [Tdata].Value
Set z = CreateObject("Scripting.Dictionary") ' zone contient individu et choix dans l'ordre des points
Set c = CreateObject("Scripting.Dictionary") ' choix par individu
For i = 1 To UBound(data)
z(data(i, 3)) = z(data(i, 3)) & data(i, 1) & "," & data(i, 4) & "|"
c(data(i, 1)) = c(data(i, 1)) & data(i, 3) & "," & data(i, 4) & "|"
Next
Do
drapeau = True
For Each lieu In z.Keys
tz = Split(z(lieu), "|")
For i = 0 To Application.Min(UBound(tz), nb(lieu)) - 1
individu = Split(tz(i), ",")(0)
choix = Split(tz(i), ",")(1)
tc = Split(c(individu), "|")
For ii = 0 To UBound(tc) - 1
autrelieu = Split((tc(ii)), ",")(0)
autrechoix = Split((tc(ii)), ",")(1)
If autrechoix > choix Then
drapeau = False
c(individu) = Replace(c(individu), autrelieu & "," & autrechoix & "|", "")
z(autrelieu) = Replace(z(autrelieu), individu & "," & autrechoix & "|", "")
End If
Next
Next
Next
Loop Until drapeau
With Sheets("Resultat").ListObjects(1)
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
For Each lieu In z.Keys
tz = Split(z(lieu), "|")
For i = 0 To Application.Min(UBound(tz), nb(lieu)) - 1
individu = Split(tz(i), ",")(0)
.ListRows.Add
.DataBodyRange(.ListRows.Count, 1).Value = individu
.DataBodyRange(.ListRows.Count, 2).Value = lieu
Next
Next
.Sort.Apply
End With
Sheets("Resultat").Select
[fin] = Now
MsgBox "Terminé !"
End Sub
Je vais maintenant tester un jeu de 10.000 individus pour vérifier la capa mémoire.