Problème mêmes valeurs dans liste déroulante

Private Sub ComboDpt_Change()
    Dim cell As Range, d As Object
    If ComboDpt <> "" Then
    ComboVille.Clear
        ComboNom.Clear
        TextBox2 = ""
        TextBox4 = ""
        TextBox7 = ""
        TextBox8 = ""
        TextBox9 = ""
        Label21.Caption = ""
       
      With Sheets("entreprises")
            [COLOR="Red"]Set d = CreateObject("Scripting.Dictionary")[/COLOR]
            For Each cell In .Range("H2:H" & .Range("C65536").End(xlUp).Row)
                If cell = ComboDpt Then d(cell.Offset(0, -1).Value) = cell.Offset(0, -1).Value
            Next
            ComboVille.List = d.Items
      End With
    End If
End Sub

Private Sub ComboDpt_Change()
    Dim cell As Range[COLOR="Red"][B], Villes As String[/B][/COLOR]
    If ComboDpt <> "" Then
    ComboVille.Clear
        ComboNom.Clear
        Me.TextBox2 = ""
        Me.TextBox4 = ""
        Me.TextBox7 = ""
        Me.TextBox8 = ""
        Me.TextBox9 = ""
        Label21.Caption = ""
                  
      [COLOR="Red"][B]Villes = ""[/B][/COLOR]
      With Sheets("entreprises")
            For Each cell In .Range("H2:H" & .Range("C65536").End(xlUp).Row)
                [COLOR="Red"][B]If cell = ComboDpt And InStr(Villes, Range("G" & cell.Row)) = 0 Then
                    Villes = Villes & "*" & Range("G" & cell.Row)[/B][/COLOR]
                    Me.ComboVille.AddItem (cell.Offset(0, -1))
                End If
            Next
      End With
    End If
End Sub