Option Explicit
Sub test2()
Dim Dico As Object
Set Dico = CreateObject("scripting.dictionary")
Dim k As Variant ' La clé du dictonnaire
Dim cel As Range ' Boucle colonne "B" NoDossier (Pour comprendre ci dessous)
Dim myarray As Variant 'Item du dictionnaire = Array(cel.Text, 1, cel.Offset(, 2).Value)
Dim LiG As ListRow
'NoDossier (Pour comprendre ci dessous)
'ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Select
For Each cel In ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Cells
If Not Dico.Exists(cel.Text) Then
' La clé du dictonnaire = cel.Text | l'Item du dictionnaire = Array(cel.Text, 1, cel.Offset(, 2).Value)
Dico(cel.Text) = Array(cel.Offset(, -1).Text, _
cel.Text, _
1, _
cel.Offset(, 1).Value, _
cel.Offset(, 2).Value, _
cel.Offset(, 3).Value)
Else
myarray = Dico(cel.Text)
myarray(2) = myarray(2) + 1
Dico(cel.Text) = myarray
End If
Next
'tes 3 valeurs pour chaque NoDOSSIER ,sont dans les items du dico (sous la forme d'un array)lse
'a savoir [ NoDossier , occurence , IdPerson]
With Feuil2.ListObjects("TbRes")
' Vider le tableau
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
For Each k In Dico
myarray = Dico(k)
If myarray(2) = 1 Then
' Ajouter une ligne au tableau
Set LiG = .ListRows.Add
myarray = Dico(k)
LiG.Range(, 1) = myarray(0)
LiG.Range(, 2) = myarray(1)
'Le_compteur = myarray(2) ' Le compteur
LiG.Range(, 3) = myarray(3)
LiG.Range(, 4) = myarray(4)
LiG.Range(, 5) = myarray(5)
Debug.Print Join(Dico(k), " | ") 'tes 3 valeurs pour chaque NoDOSSIER
Else
' Je voudrais supprimer toutes les clés dont l'occurrence est > 1
Dico.Remove k
End If
Next k
End With
End Sub