ListBox'a benzersiz veri alınması

[Korhan Ayhan]

Aşağıdaki gibi kullanırsanız ListBox nesnesinden boş satırlar görünmez.

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
    
    ListBox1.Clear
    
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
    
    ReDim Veri(1 To 5, 1 To 1)
    
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            If UCase(Left(Liste(X, 1), 1)) = "A" Then
                Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
                .Item(Aranan) = 1
                Say = Say + 1
                ReDim Preserve Veri(1 To 5, 1 To Say)
                For Y = 1 To 5
                    Veri(Y, Say) = Liste(X, Y)
                Next
            End If
        Next
    End With
        
    If Say > 0 Then
        ListBox1.ColumnCount = 5
        ListBox1.Column = Veri
    End If
End Sub

 

[tamer42]

Aşağıdaki gibi kullanırsanız ListBox nesnesinden boş satırlar görünmez.

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
   
    ListBox1.Clear
   
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
   
    ReDim Veri(1 To 5, 1 To 1)
   
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            If UCase(Left(Liste(X, 1), 1)) = "A" Then
                Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
                .Item(Aranan) = 1
                Say = Say + 1
                ReDim Preserve Veri(1 To 5, 1 To Say)
                For Y = 1 To 5
                    Veri(Y, Say) = Liste(X, Y)
                Next
            End If
        Next
    End With
       
    If Say > 0 Then
        ListBox1.ColumnCount = 5
        ListBox1.Column = Veri
    End If
End Sub

Teşekkürler Hocam

 

[walabi]

Merhaba,

Aşağıdaki kod satırları listbox2 ye M ve N sütunlarındaki verileri M ye göre süzdürerek getirebiliyorum. Bu değerlerin benzersiz olması için kod satırlarında ne olmalı.

Sub Stok_Ara_1()

On Error Resume Next

Set S1 = Sheets("Detaylı_Alış_Faturaları")
ListBox2.ColumnCount = 2
ListBox2.ColumnWidths = "80;80"
Dim a As Long, i As Long
    ReDim dizial(1 To 29, 1 To 1)
    If TextBox2.Text = "" Then Exit Sub
    ListBox2.Clear
    
    With CreateObject("Scripting.Dictionary")
    For i = 2 To S1.Cells(Rows.Count, 13).End(3).Row
        If UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ")) Like _
        "*" & UCase(Replace(Replace(TextBox2.Text, "ı", "I"), "i", "İ")) & "*" Then
        
      
            a = a + 1
            ReDim Preserve dizial(1 To 29, 1 To a)
            dizial(1, a) = S1.Cells(i, "M") ' Malzeme adı
            dizial(2, a) = S1.Cells(i, "N") ' stok kodu

            
        End If
    Next i
    ListBox2.Column = dizial
    End With
    Erase dizial
    a = Empty
    i = Empty
 
End Sub

 

[Korhan Ayhan]

Kodlarınızda "Dictionary" nesnesi satır olarak yazılmış. Bu nesne ile benzersizlik koşulunu uygulayabilirsiniz. Ama gördüğüm kadarıyla "Dictionary" nesnesi yazılmasına rağmen kod içinde hiç kullanılmamış.

Kod içinde ki aşağıdaki koyu satırı bulun ve hemen altına aşağıdaki satırı ekleyin.

a = a + 1


If Not .Exists(UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ"))) Then
.Add UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ")), a

Döngünün içindeki End If satırının üstüne bir End If daha ekleyip deneyiniz.

 

[walabi]

Kodlarınızda "Dictionary" nesnesi satır olarak yazılmış. Bu nesne ile benzersizlik koşulunu uygulayabilirsiniz. Ama gördüğüm kadarıyla "Dictionary" nesnesi yazılmasına rağmen kod içinde hiç kullanılmamış.

Kod içinde ki aşağıdaki koyu satırı bulun ve hemen altına aşağıdaki satırı ekleyin.

a = a + 1


If Not .Exists(UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ"))) Then
.Add UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ")), a

Döngünün içindeki End If satırının üstüne bir End If daha ekleyip deneyiniz.

Korhan bey cevabınızı yeni gördüm iş yoğunluğumdan dolayı, öncelikle teşekkürler, kendi dosyama uyarlamaya çalışacağım.

 

[walabi]

Kodlarınızda "Dictionary" nesnesi satır olarak yazılmış. Bu nesne ile benzersizlik koşulunu uygulayabilirsiniz. Ama gördüğüm kadarıyla "Dictionary" nesnesi yazılmasına rağmen kod içinde hiç kullanılmamış.

Kod içinde ki aşağıdaki koyu satırı bulun ve hemen altına aşağıdaki satırı ekleyin.

a = a + 1


If Not .Exists(UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ"))) Then
.Add UCase(Replace(Replace(S1.Cells(i, "M"), "ı", "I"), "i", "İ")), a

Döngünün içindeki End If satırının üstüne bir End If daha ekleyip deneyiniz.

Korhan Bey,

Cevabınız için tekrardan teşekkürler, yazdıklarınızı yaptıktan sonra aradığım sonucu ulaşabiliyorum.

Yalnız aralıklı boş satırlar oluşmakta. Bunun sebebi ne olabilir. Veri aldığım M ve N sütunlarında boş hücre hiç yok. Örneğin ilgili textboxa * karakterini girip tüm benzersizleri listeleyebildiğimi düşünüyorum. Listboxda listelenen satırlarda veri olmayan boş satırlar görünüyor.

Açıkcası çok önemli değil kod işimi gördüğü sürece ancak sadece sebebini merak ettim.

 

[Korhan Ayhan]

Ben kodunuzu çok detaylı incelemedim. Örnek dosya paylaşırsanız sıkıntıyı anlayabiliriz.

 

[walabi]

Ben kodunuzu çok detaylı incelemedim. Örnek dosya paylaşırsanız sıkıntıyı anlayabiliriz.

Örnek dosya ektedir, asıl dosyadan alıntı olduğu için bazı bilgileri temizledim. Ctrl + g ile gelen userform üzerinde fiyat sorgulama ile açılan userform aldındaki kodlardır.

 

[oguzoguzaslan55]

Değerli arkadaşlar,
aşağıdaki gibi bir kodlama kullanıyorum. Tek sorunum Listbox a veriler çift gelende var çünkü kaynağında çift kayıtlar var. bunu Listbox a benzersin kayırları nasıl alabilirim. Desteğinizi rica ederim.

Sub KayıtlarıAl()
Dim KayıtSayısı As Variant
ListBox1.Clear
KayıtSayısı = Sheets("Urunler").Cells(Rows.Count, "C").End(xlUp).Row
For Satır = 3 To KayıtSayısı
If InStr(UCase(Sheets("Urunler").Range("C" & Satır)), TextBox1.Value) > 0 Then
ListBox1.AddItem Sheets("Urunler").Range("C" & Satır)
End If
Next Satır
End Sub


Private Sub ListBox1_Click()
ActiveCell.Value = ListBox1.Value
Unload UserForm1
End Sub

Private Sub TextBox1_Change()
Dim text As Variant
text = TextBox1.text: text = UCase(text): TextBox1.text = text
Call KayıtlarıAl
End Sub

Private Sub UserForm_Activate()
Call KayıtlarıAl
End Sub