[kanakan52]

Arkadaşlar merhaba,
Ekteki çalışmamada Combobox2, Combobox4 te tekrarlayanları hallettim. Ama ne yaptıysam Combobox3 te tekrarlayanları getirmemeyi başaramadım.

Tam olarak istediğim Combobox3 e DATA2 sayfasında C sütunundaki verileri benzersiz olarak almak. Lütfen yardım rica ediyorum.

[Orion1]

VBA Şifreli dosyanıza yanıt beklemeyin.

[feraz]

Merhaba pasif yaptığınız kodu aktif yapınca normalde çalışıyor.
CreateObject("Scripting.Dictionary") ekledim combo3 için.
Birde alttaki gibi deneyin.

Kod: Tümünü seç

Private Sub userform_Initialize()

Dim combo3 As Object
Set combo3 = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = True
For i = 2 To Sayfa1.[A65536].End(3).Row
'If WorksheetFunction.CountIf(Sayfa4.Range("AQ2:AQ" & i), Sayfa4.Cells(i, "AQ")) = 1 Then ComboBox1.AddItem Sayfa1.Cells(i, "AQ").Value
If WorksheetFunction.CountIf(Sayfa1.Range("A2:A" & i), Sayfa1.Cells(i, "A")) = 1 Then ComboBox2.AddItem Sayfa1.Cells(i, "A").Value
If WorksheetFunction.CountIf(Sayfa1.Range("B2:B" & i), Sayfa1.Cells(i, "B")) = 1 Then ComboBox4.AddItem Sayfa1.Cells(i, "B").Value
If WorksheetFunction.CountIf(Sayfa1.Range("D2:D" & i), Sayfa1.Cells(i, "D")) = 1 Then ComboBox5.AddItem Sayfa1.Cells(i, "D").Value
'If WorksheetFunction.CountIf(Sayfa1.Range("C2:C" & i), Sayfa1.Cells(i, "C")) = 1 Then ComboBox3.AddItem Sayfa1.Cells(i, "C").Value
combo3.Item(Sayfa1.Cells(i, "C").Value) = Sayfa1.Cells(i, "C").Value
Next

ComboBox3.List = combo3.Items
Application.ScreenUpdating = True
Set combo3 = Nothing
End Sub

[kanakan52]

Sayın Orion1 merhaba,
Vba şifresi : 6773436 . Belirtmeyi unutmuşum özür dilerim.

Sayın Feraz kodlar için teşekkür ederim.
Maalesef Combo3 yine süzme yapmıyor. Ben mi bir şeyleri yanlış yapıyorum. Görseldeki gibi oluyor.

[feraz]

Merhaba.

Benim kod userform açılışında combo3 e benzersiz veri alıyor.

Diğer comboboxları seçince combo3 olayına bakmamıştım.

Mantık aynıdır zaten.Pc yi açınca bakarım.

[kanakan52]

Forumdan ayrılmıyorum bir yardım gelecek diye Çok makbule geçecek Sn. Feraz.. Teşekkürler.

[feraz]

Rica ederiz Ümit Bey

Deneyiniz.Aynı mantıkla yaptım.

Kod: Tümünü seç

Private Sub ComboBox4_Change()

Dim combo3 As Object
Set combo3 = CreateObject("Scripting.Dictionary")

ComboBox3.Clear
For i = 2 To Sayfa1.[A65536].End(3).Row
  If Sayfa1.Cells(i, "A").Text = ComboBox2.Text And Sayfa1.Cells(i, "B").Text = ComboBox4.Text Then
   For a = 0 To ComboBox3.ListCount - 1
        If Sayfa1.Cells(i, "B").Value = ComboBox3.List(a, 0) Then
          evn = True
          Exit For
        Else
          evn = False
        End If
    Next
        If evn = False Then
          combo3.Item(Sayfa1.Cells(i, "C").Value) = Sayfa1.Cells(i, "C").Value
        End If
          evn = False
End If
Next
ComboBox3.List = combo3.Items
Set combo3 = Nothing

End Sub

[kanakan52]

Ellerinize sağlık. Ümidimi kesmiştim. Allah razı olsun..

[feraz]

Sizdende.

Userform açılışında çoklu veride yavaş açılmaması için kod eklerim birazdan denersiniz onuda.

Bence öyle daha hızlı olur.

[kanakan52]

Çok makbule geçer. Bende projeyi tamamlayıp paylaşırım. Belki birilerinin işine yarar..

[feraz]

Private Sub userform_Initialize() kodunu silip alttaki kodu ekleyin.

Function kodunuda boş bir yere ekleyin alfabetik sıralama için.
Bu kodlar userform açılışı için sadece.Hem hızlı çalışır hemde alfabetik sıralama yapar.
Comboboxların değiştirilme olayına görede aynı mantıkla uygulanabilinir.

5000 satır için userform açılma süresi bende 1 veya 2 saniye sürdü.

Kod: Tümünü seç

Private Sub userform_Initialize()

Dim combo2 As Object, combo3 As Object, combo4 As Object, a, b, c

Set combo2 = CreateObject("Scripting.Dictionary")
Set combo3 = CreateObject("Scripting.Dictionary")
Set combo4 = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = True
    For i = 2 To Sayfa1.[A65536].End(3).Row
        combo2.Item(Sayfa1.Cells(i, "A").Value) = Sayfa1.Cells(i, "A").Value
        combo3.Item(Sayfa1.Cells(i, "C").Value) = Sayfa1.Cells(i, "C").Value
        combo4.Item(Sayfa1.Cells(i, "B").Value) = Sayfa1.Cells(i, "B").Value
    Next
   
      a = combo2.items
      b = combo3.items
      c = combo4.items
        Call xx(a)
        Call xx(b)
        Call xx(c)
    On Error Resume Next
     ComboBox2.List = a
     ComboBox3.List = b
     ComboBox4.List = c
Application.ScreenUpdating = True

Set combo2 = Nothing: Set combo3 = Nothing: Set combo4 = Nothing: Erase a: Erase b: Erase c

End Sub

Kod: Tümünü seç

Function xx(yy As Variant)

       For i = LBound(yy) To UBound(yy) - 1
        For j = i + 1 To UBound(yy)
            If StrComp(yy(i), yy(j), vbTextCompare) = 1 Then
                x = yy(j)
                yy(j) = yy(i)
                yy(i) = x
            End If
        Next j
    Next i

End Function

[kanakan52]

Sayın Feraz,
Rutin işlerimi bitirip kodlarınızı deneyip bilgi vereceğim. Dediğiniz gibiyse çok süper olacak inşallah.
Sağolun.

[feraz]

Birde alttaki gibi kısa kod var.Bunun çalışması için Microsoft .NET Framework 2.0 yüklü olması gerekmiş bilgisayarda.

Kodları denersiniz bence bu kod daha iyi gibi.Kodlar sadece Userform açılışı için.

https://www.microsoft.com/tr-TR/download/details.aspx?id=1639

Kod: Tümünü seç

Private Sub userform_Initialize()

Dim objArrLst, objArrLst1, objArrLst2, i As Long

Set objArrLst = CreateObject("System.collections.arraylist")
Set objArrLst1 = CreateObject("System.collections.arraylist")
Set objArrLst2 = CreateObject("System.collections.arraylist")

On Error Resume Next

Application.ScreenUpdating = False

With Sheets("DATA2")

    For i = 2 To .Cells(Rows.Count, "A").End(3).Row
        If Not objArrLst.contains(.Cells(i, "A").Value) And .Cells(i, "A").Value <> "" Then
            objArrLst.Add .Cells(i, "A").Value
         End If
         
        If Not objArrLst1.contains(.Cells(i, "B").Value) And .Cells(i, "B").Value <> "" Then
            objArrLst1.Add .Cells(i, "B").Value
        End If
       
         If Not objArrLst2.contains(.Cells(i, "C").Value) And .Cells(i, "C").Value <> "" Then
            objArrLst2.Add .Cells(i, "C").Value
        End If
         
    Next

objArrLst.Sort
objArrLst1.Sort
objArrLst2.Sort

ComboBox2.List = objArrLst.ToArray
ComboBox4.List = objArrLst1.ToArray
ComboBox3.List = objArrLst2.ToArray

End With
Application.ScreenUpdating = True

Set objArrLst = Nothing: Set objArrLst1 = Nothing: Set objArrLst1 = Nothing

End Sub

[kanakan52]

Sayın Feraz,
Son kodlarınızı deneme fırsatım olmadı. Daha doğrusu bir önceki kodlarınız stabil çalıştığı için macera aramanın anlamı yok diye düşündüm.. Emeğinize çok çok teşekkür ediyorum... Allah razı olsun.

[feraz]

Sizdende üstad.

Sadece son kodun farkı sıralama yapıyordu.

Yoksa aynı işi görür zaten.

Kolay gelsin.

[kanakan52]

Teşekkür ederim çok sağolun..