Scripting Dictionary (même item sur différentes keys)

Option Explicit
Option Base 1

Sub lister_Pays_par_ville()
Dim Nbre As Integer
Dim T_pays, Cptr_a As Integer, Lig As Long
Dim D_ville As Object, Cptr_b As Integer, Ville As String

'initialisations
Application.ScreenUpdating = False
Range("G2:H1000").Clear
Set D_ville = CreateObject("scripting.dictionary")
Nbre = Application.CountIf(Columns("A"), "*dans le pays*")
ReDim T_pays(Nbre, 3)
Lig = Rows.Count

For Cptr_a = 1 To Nbre
     'limites par pays
     Lig = Columns("A").Find("dans le pays", Cells(Lig, "A")).Row
     T_pays(Cptr_a, 1) = Lig
     If Cptr_a = UBound(T_pays) Then
          T_pays(Cptr_a, 2) = Columns("A").Find("*", , , , , xlPrevious).Row
     Else
          T_pays(Cptr_a, 2) = Columns("A").Find("dans le pays", Cells(Lig, "A")).Row
     End If
     'nom pays 'SENSIBLE A LA CASSE
     T_pays(Cptr_a, 3) = Application.Substitute(Cells(Lig, "A"), "dans le pays ", "")
     
     'affectations au dictionary
     For Cptr_b = T_pays(Cptr_a, 1) To T_pays(Cptr_a, 2)
          Ville = Cells(Cptr_b, "B")
          If Ville <> "" Then
               If Not D_ville.exists(Ville) Then
                    D_ville.Add Ville, T_pays(Cptr_a, 3) & " "
               Else
                    D_ville.Item(Ville) = D_ville.Item(Ville) & T_pays(Cptr_a, 3) & " "
                    'test = D_ville.Item(Ville)
               End If
          End If
     Next
Next
'restitution pays par ville
Range("G2").Resize(D_ville.Count, 1) = Application.Transpose(D_ville.Keys)
Range("H2").Resize(D_ville.Count, 1) = Application.Transpose(D_ville.items)
End Sub

--