• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

ComboBox a benzersiz alfabetik sıralama

U

umitumit

Altın Üye
Katılım
5 Eylül 2006
Mesajlar
364
Excel Vers. ve Dili
Excel 2016
Türkçe
Sayfa1 de A sütununda A10:A100 arasında bir listem var.
istediğim şey ComboBox1 e bu listedeki verileri alfabetik olarak benzersiz sıralamak.
Yani aynı isimler bir defa listeye gelecek....

şimdiden ilgilenen arkadaşlara çok çok teşekkürler
 
Aşağıdaki kodu dener misiniz ?
Kod: 
Private Sub UserForm_Initialize()
For x = 10 To Cells(65536, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("A10:A" & x), Cells(x, 1)) = 1 Then
ComboBox1.AddItem Cells(x, 1).Value
End If
Next
End Sub
 
Son düzenleme:
Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Kod: 
Option Explicit
 
Private Sub UserForm_Initialize()
    Dim X As Long
    Columns(256).Clear
    Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("IV1"), Unique:=True
    Columns(256).Sort Key1:=Range("IV1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    For X = 2 To [IV65536].End(3).Row
    ComboBox1.AddItem Cells(X, 256)
    Next
    Columns(256).Clear
End Sub
 

Ekli dosyalar

Başka bir alternatif.:cool:
Dosya ektedir.:cool:
Kod: 
Private Sub CommandButton1_Click()
Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
ComboBox1.Clear
With CreateObject("Scripting.Dictionary")
    For Each hcr In Range("A10:A" & Cells(65536, "A").End(xlUp).Row)
        If Not .exists(hcr.Value) Then
            .Add hcr.Value, Nothing
        End If
    Next hcr
a = .keys
End With
For i = LBound(a) To UBound(a) - 1
    For j = i + 1 To UBound(a)
        If StrComp(a(i), a(j)) = 1 Then
            x = a(j)
            a(j) = a(i)
            a(i) = x
        End If
    Next j
Next i
On Error Resume Next
ComboBox1.List = a
ComboBox1.ListIndex = 0
End Sub
 

Ekli dosyalar

SN Ozgretmen
SN KORHAN AYHAN
SN EVREN GİZLEN
çok teşekkür ederim.

şimdi gelelim günün sorusuna...
excel içindeki sayfalarda olan verilerimi önce bir sütunda;

=TOPLA.ÇARPIM((CD5<$CD$5:$CD$204)/EĞERSAY($CD$5:$CD$204;$CD$5:$CD$204&""))+1

ile, daha sonra bunun yanındaki sütunda;

=KÜÇÜK($CE$5:$CE$204;SATIR(CD1))

fonksiyonları ile küçükten büyüğe değer sıralaması yaptırıp daha sonra da yine yanındaki sütunda ;

{=İNDİS($CD$5:$CD$204;KÜÇÜK(EĞER($CE$5:$CE$204=CF5;SATIR($CE$5:$CE$204)-SATIR($CF$5)+1);EĞERSAY($CF$5:CF5;CF5)))}

kullanarak sıralıyorum. tabi bu da excelin epey bi hesaplaması ile oluyor.
yukarıdaki macro örneklerini görünce aklıma geldi.
acaba CD sütunundaki yaklaşık 1000 satırlık veriyi, macro benim için CF sütununa (sütun isimleri önemli değil, ben kendi dosyamdan kopyaladığım için CD falan oldu) sıralayabilir mi?
 
Son düzenleme:
hoppalaaaaa....
hata oluştu. daha doğrusu ben yanlış anlattığım için hata oluştu.
alfabetik sıralama yapılacak veriler PAKET isimli sayfada mevcut.
ben ise combobox u diğer sayfalar içinde kullanıyorum.
şu an açık olan sayfaya göre A sütunundaki verileri sıralıyor.
oysa sadece PAKET isimli sayfanın A sütunundaki verileri sıralama yapmalı.
yani aşağıdaki macroda sayfayı sabitlememiz gerekiyor.

Private Sub CommandButton1_Click()
Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
ComboBox1.Clear
With CreateObject("Scripting.Dictionary")
For Each hcr In Range("A10:A" & Cells(65536, "A").End(xlUp).Row)
If Not .exists(hcr.Value) Then
.Add hcr.Value, Nothing
End If
Next hcr
a = .keys
End With
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If StrComp(a(i), a(j)) = 1 Then
x = a(j)
a(j) = a(i)
a(i) = x
End If
Next j
Next i
On Error Resume Next
ComboBox1.List = a
ComboBox1.ListIndex = 0
End Sub
 
Son düzenleme:
Aşağıdakini deneyiniz:cool:
Kod: 
Private Sub CommandButton1_Click()
Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
[B][COLOR="Red"]Dim pk As Worksheet[/COLOR][/B]
ComboBox1.Clear
[B][COLOR="red"]Set pk = Sheets("PAKET")[/COLOR][/B]
With CreateObject("Scripting.Dictionary")
For Each hcr In [B][COLOR="red"]pk.[/COLOR][/B]Range("A10:A" & [B][COLOR="red"]pk.[/COLOR][/B]Cells(65536, "A").End(xlUp).Row)
If Not .exists(hcr.Value) Then
.Add hcr.Value, Nothing
End If
Next hcr
a = .keys
End With
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If StrComp(a(i), a(j)) = 1 Then
x = a(j)
a(j) = a(i)
a(i) = x
End If
Next j
Next i
On Error Resume Next
ComboBox1.List = a
ComboBox1.ListIndex = 0
End Sub
 
olmadı sn evren gizlen


bi saniye bi saniyeeeee....
aşağıdaki pk. ları görmemişim.
bi deneme daha yapayım bakayım


tamamdııırrrrr....
teşekkür ederim
 
Son düzenleme:
umitumit' Alıntı:
olmadı sn evren gizlen


bi saniye bi saniyeeeee....
aşağıdaki pk. ları görmemişim.
bi deneme daha yapayım bakayım


tamamdııırrrrr....
teşekkür ederim
Genişletmek için tıkla ...
Rica ederim.
İyi çalışmalar.:cool:
 
Ben nedense her zaman ADO ile bunları yapmak tarafındayım. :)
Daha mı kolayıma geliyor ne ? :)

A sütununda karışık harfli iller yazılı olduğunu farz ettim ve aşağıdaki sorgu ile sıralatarak comboya aldık, daha hızlı oldu gibi...

Kod: 
Set rs = con.Execute("select distinct iller from [Sayfa1$]")
If Not rs.EOF Then ComboBox1.Column = rs.getrows
 
herkese yardımlarından ötürü çok teşekkürler
şimdi gelelim günün sorusuna...
excel içindeki sayfalarda olan verilerimi önce bir sütunda;

=TOPLA.ÇARPIM((CD5<$CD$5:$CD$204)/EĞERSAY($CD$5:$CD$204;$CD$5:$CD$204&""))+1

ile, daha sonra bunun yanındaki sütunda;

=KÜÇÜK($CE$5:$CE$204;SATIR(CD1))

fonksiyonları ile küçükten büyüğe değer sıralaması yaptırıp daha sonra da yine yanındaki sütunda ;

{=İNDİS($CD$5:$CD$204;KÜÇÜK(EĞER($CE$5:$CE$204=CF5 ;SATIR($CE$5:$CE$204)-SATIR($CF$5)+1);EĞERSAY($CF$5:CF5;CF5)))}

kullanarak sıralıyorum. tabi bu da excelin epey bi hesaplaması ile oluyor.
yukarıdaki macro örneklerini görünce aklıma geldi.
acaba CD sütunundaki yaklaşık 1000 satırlık veriyi, macro benim için CF sütununa (sütun isimleri önemli değil, ben kendi dosyamdan kopyaladığım için CD falan oldu) sıralayabilir mi?

--------------------------------------------------------------------------------
 
Sayı Korhan Ayhan eski bir konu, ancak güzel bir çalışma. Listede yazılan harflere uygun olanları kalması, diğerlerinin gözükmemesi nasıl sağlanır.
 
Eskilerden bulduğum bu konu hakkında tekrar yardıma ihtiyacım var arkadaşlar.

BASIM isimli sayfamın J61:J671 satırları arasındaki hücreleri benzersiz ve alfabetik olarak combobox1 e getirmek istiyorum.

Aşağıdaki macro yu kullanmaya çalışıyorum ama olmuyor.

Hata nerdedir?

Private Sub Combobox1_Click()
Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
Dim pk As Worksheet
ComboBox1.Clear
Set pk = Sheets("BASIM")
With CreateObject("Scripting.Dictionary")
For Each hcr In pk.Range("j61:j" & pk.Cells(671, "j").End(xlUp).Row)
If Not .exists(hcr.Value) Then
.Add hcr.Value, Nothing
End If
Next hcr
a = .keys
End With
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If StrComp(a(i), a(j)) = 1 Then
x = a(j)
a(j) = a(i)
a(i) = x
End If
Next j
Next i
On Error Resume Next
ComboBox1.List = a
ComboBox1.ListIndex = 0
End Sub
 
Foruma kod eklerken lütfen code (#) tagını kullanın. Daha düzenli görünecektir.

Kodun içindeki aşağıdaki satırı güncelleyin.

Eski hali;
Kod: 
For Each hcr In pk.Range("j61:j" & pk.Cells(671, "j").End(xlUp).Row)

Yeni hali;
Kod: 
For Each hcr In pk.Range("j61:j671")
 
Kod: 
Private Sub ComboBox1_Enter()
    Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
    Dim pk As Worksheet
    ComboBox1.Clear
    Set pk = Sheets("BASIM")
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For Each hcr In pk.Range("j61:j" & pk.Cells(671, "j").End(xlUp).Row)
            If Not .exists(hcr.Value) Then
                .Add hcr.Value, Nothing
            End If
        Next hcr
        a = .keys
    End With

    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            If StrComp(a(i), a(j), vbTextCompare) = 1 Then
                x = a(j)
                a(j) = a(i)
                a(i) = x
            End If
        Next j
    Next i
    On Error Resume Next
    ComboBox1.List = a
    ComboBox1.ListIndex = 0

End Sub
 
Sayın Korhan Ayhan,

Sizin düzeltmeniz nedenini bilmemekle birlikte, çalışmadı.
Cevabınız için elinize sağlık.

Sayın Veysel Emre,

Sizin öneriniz çalıştı ve gayet başarılı.
Teşekkürler, emeğinize sağlık.
 
Arkaşlar çok faydalı oldu teşekkür ederim.
Bir sorum olacak;
Bu formülleri ; Forma değil de Sayfaya eklenen Combobox lara nasıl uygularız.
 
Aşağıdaki koda alfabetik sıralama eklenebilirmi

Private Sub UserForm_Initialize()
For x = 11 To Cells(65536, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("A11:A" & x), Cells(x, 1)) = 1 Then
ComboBox1.AddItem Cells(x, 1).Value
End If
Next
End Sub
 
Arkadaşlar merhaba,

Sizler sayesinde yazılan ve kullandığım aşağıdaki macroyu aynı dosyanın "GIRIS" sayfasının e4:e100 sütununa uyarlamak istedim, başarılı olamadım. Nerede hata yaptım acaba?

BASIM sayfasının çalışan macrosu;

Private Sub ComboBox1_Enter()
Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
Dim pk As Worksheet
ComboBox1.Clear
Set pk = Sheets("BASIM")
With CreateObject("Scripting.Dictionary")
.comparemode = vbTextCompare
For Each hcr In pk.Range("j61:j" & pk.Cells(671, "j").End(xlUp).Row)
If Not .exists(hcr.Value) Then
.Add hcr.Value, Nothing
End If
Next hcr
a = .keys
End With

For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If StrComp(a(i), a(j), vbTextCompare) = 1 Then
x = a(j)
a(j) = a(i)
a(i) = x
End If
Next j
Next i
On Error Resume Next
ComboBox1.List = a
ComboBox1.ListIndex = 0

End Sub


"GIRIS" sayfasına kopyaladığım ama sadece E sütununun ilk hücresini gösteren macrom;

Private Sub ComboBox2_Enter()
Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant
Dim pk As Worksheet
ComboBox2.Clear
Set pk = Sheets("GIRIS")
With CreateObject("Scripting.Dictionary")
.comparemode = vbTextCompare
For Each hcr In pk.Range("e4:e" & pk.Cells(100, "e").End(xlUp).Row)
If Not .exists(hcr.Value) Then
.Add hcr.Value, Nothing
End If
Next hcr
a = .keys
End With

For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If StrComp(a(i), a(j), vbTextCompare) = 1 Then
x = a(j)
a(j) = a(i)
a(i) = x
End If
Next j
Next i
On Error Resume Next
ComboBox2.List = a
ComboBox2.ListIndex = 0

End Sub



ve aynı macroyu sayısal verilerin sıralamasında kullanmak için ne yapmalıyım?
 
Son düzenleme:
Aşağıdaki gibi deneyiniz.

Kod bende çalıştı. Sadece sayısal sıralama olayını düzelttim.

Kod: 
Private Sub ComboBox2_Enter()
    Dim a As Variant, hcr As Range, i As Long, j As Long, x As Variant, pk As Worksheet
    
    ComboBox2.Clear
    Set pk = Sheets("GIRIS")
    
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For Each hcr In pk.Range("e4:e" & pk.Cells(100, "e").End(xlUp).Row)
            If Not .exists(hcr.Value) Then
                .Add hcr.Value, Nothing
            End If
        Next hcr
        a = .keys
    End With
    
    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            If a(i) > a(j) Then
                x = a(j)
                a(j) = a(i)
                a(i) = x
            End If
        Next j
    Next i
    
    On Error Resume Next
    ComboBox2.List = a
    ComboBox2.ListIndex = 0
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst