Combobox Benzersiz Listeleme

[Yesilyurtlu]

Sayfa1 D3 : D sütununda yer alan isimlerden benzersiz olarak Combobox a almak için ne yapabilirim?

 

[İhsan Tank]

dosya ekler misiniz

 

[Yesilyurtlu]

İhsan Abi
Combobox ile seçtiğim de J1 hücresine yazabilir mi?

 

[Necdet]

Merhaba,

Aşağıdaki kodlar ThisWorkbook'un kod sayfasına kopyalayınız.

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Sheets("Sayfa2").Select
Sheets("GİRİŞ").Select
Application.ScreenUpdating = True
End Sub

Aşağıdaki kodları ise GİRİŞ sayfasının Kod Bölümüne Aşağıdaki kodları kopyalayıız.

Private Sub Worksheet_Activate()
Dim i As Long
ComboBox1.Clear
For i = 3 To Cells(Rows.Count, "D").End(3).Row
    If Application.WorksheetFunction.CountIf(Range("D3:D" & i), Cells(i, "D")) = 1 Then ComboBox1.AddItem Cells(i, "D")
Next i
End Sub

 

[Yesilyurtlu]

Necdet Abi
Var olasın. Ellerine Sağlık.
TEŞEKKÜR EDERİM

 

[Necdet]

Tekrar merhaba,

Önceki kodlar içime sinmedi, comboboxtaki verileri de sıralamak daha uygun olur diye düşündüm.

Aşağıdaki kodlar ThisWorkbook'un kod bölümünde olmalı

Private Sub Workbook_Open()
 
    Application.ScreenUpdating = False
    Sheets("Sayfa2").Select
    Sheets("GİRİŞ").Select
    Application.ScreenUpdating = True
 
End Sub

Aşağıdaki kodlarda GİRİŞ sayfasının kod bölümünde olmalı.

Private Sub Worksheet_Activate()
Dim d
Dim i As Integer
Dim s
Dim deg As Variant
Dim a
Set d = CreateObject("Scripting.Dictionary")
For i = 3 To Cells(Rows.Count, "D").End(3).Row
    deg = Cells(i, "D")
    If Not d.exists(deg) Then d.Add deg, ""
Next i
a = d.keys
BubbleSort a
ComboBox1.List = a
End Sub

Function BubbleSort(TempArray As Variant)
    Dim Temp        As Variant
    Dim i           As Long
    Dim NoExchanges As Boolean
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
        ' Loop through each element in the array.
        For i = 0 To UBound(TempArray) - 1
            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If StrComp(TempArray(i), TempArray(i + 1), 1) = 1 Then
                NoExchanges = False
                Temp = TempArray(i)
                TempArray(i) = TempArray(i + 1)
                TempArray(i + 1) = Temp
            End If
        Next i
    Loop While Not (NoExchanges)
End Function

 

[Yesilyurtlu]

Var olasın Abi.
Sonsuz Teşekkürler.
Zahmet verdim abime Hakkını Helal Et Üstad

 

[Necdet]

Hak yok
Bilgi var, o da paylaşımda
Güle güle kullanınız.