Listbox çift isimleri teke düşürme sorunu

[iaydin20]

herkese selamlar arkadaşlar ekteki dosyada listbox a sütunundaki isimleri listeleyerek gösteriyor ama aynı kişilere ait birçok kayıt olacağı için listboxta simlerin bir tane ve alfabetik sıralı gözükmesini bir türlü yapamadım yardımlarınıza ihtiyacım var şimdiden çok teşekkürler..

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub listele()
Dim sat As Long, i As Long, liste(), x As Variant
Dim z As Object, a As Long, j As Long
liste() = Range("A11:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
ListBox1.Clear
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        a = a + 1
        z.Add liste(i, 1), Nothing
    End If
Next i
liste = Application.Transpose(Array(z.keys))
Set z = Nothing
For i = 1 To UBound(liste) - 1
    For j = i To UBound(liste)
        If StrComp(liste(i, 1), liste(j, 1)) = 1 Then
            x = liste(i, 1)
            liste(i, 1) = liste(j, 1)
            liste(j, 1) = x
        End If
    Next j
Next i
If a > 0 Then ListBox1.List = liste
Erase liste
End Sub

 

[iaydin20]

Çok teşekkür ederim üstadım ellerine emeğine sağlık...