Veri doğrulama mükerrerleri kaldırma ( liste ile)

[conari]

A sütununda bulunan kayıtlar
Ali
Veli
Hasan
Ali
Hasan

Şeklinde gidiyor. bunların farklı bir sütunda teke düşürerek veri doğrulama da ad tanımlyarak kullanabiliyorum. Fakat bunları başka bir hücre aralığına süzdürmeden direk veri doğrulamada nasıl kullanabilirim. ad tanımlamada alt tarafta boşluk kalırsa onları da atarak.

 

[Erdinç E. Karaçam]

A sütununda bulunan kayıtlar
Ali
Veli
Hasan
Ali
Hasan

Şeklinde gidiyor. bunların farklı bir sütunda teke düşürerek veri doğrulama da ad tanımlyarak kullanabiliyorum. Fakat bunları başka bir hücre aralığına süzdürmeden direk veri doğrulamada nasıl kullanabilirim. ad tanımlamada alt tarafta boşluk kalırsa onları da atarak.

Merhaba,

Aşağıdaki kodları Module'e yazıp, çalıştır, sanırım istediğin bu;

Sub Benzersizleri_Ayiklayip_Ad_Tanimlayalim()
    Dim Hucreler As Range
    Dim Hucre As Range
    Dim Benzersizler As New Collection
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim YerDegistir1 As Variant
    Dim YerDegistir2 As Variant
    Dim Koleksiyonun_Parcasi As Variant
    '   Verilerimizi A1:A5 aralığında bulunduruyoruz:
    Set Hucreler = Range("A1:A5")
    On Error Resume Next
    '   Benzersiz olanları sanal bir koleksiyonda biriktiriyoruz:
        For Each Hucre In Hucreler
            Benzersizler.Add Hucre.Value, CStr(Hucre.Value)
        Next
    On Error GoTo 0
    ' Tercihe bağlı olarak koleksiyonumuzu sıralıyoruz:
    With Benzersizler
        For i = 1 To .Count - 1
            For j = i + 1 To .Count
                If Benzersizler(i) > Benzersizler(j) Then
                    YerDegistir1 = Benzersizler(i)
                    YerDegistir2 = Benzersizler(j)
                        .Add YerDegistir1, before:=j
                        .Add YerDegistir2, before:=i
                    .Remove i + 1
                    .Remove j + 1
                End If
            Next j
        Next i
    End With
    '   B sütununda 1. satırdan itibaren benzersizleri satırlara yazdırıyoruz:
    k = 1
        For Each Koleksiyonun_Parcasi In Benzersizler
            Cells(k, 2) = Koleksiyonun_Parcasi
            k = k + 1
        Next
    '   EEK isminde bir Ad - Tanımlama hazırlıyoruz:
    On Error Resume Next
    Range(Cells(1, 2), Cells(k, 2)).Select
    With ThisWorkbook
        .Names("EEK").Delete
        .Names.Add Name:="EEK", RefersToR1C1:=Range(Cells(1, 2), Cells(k * 2, 2))
    End With
    On Error GoTo 0
    Set Hucreler = Nothing
End Sub