ListBox üzerinde listelenen verilerden tek olanları sayma

[noxious]

Forum içerisinde yaptığım aramada bazı uygulamalar buldum ve bunların içerisinde aşağıdaki kodlar benim istediğim sayma işlemini yapıyor ancak elimdeki veri miktarı çok fazla ve bu kodlar ile işlem önce sayıp sonra tek olanları ListBox içerisine aldığı için çok uzun sürüyor.
Bunun yerine ListBox içerisine açılışta UserForm_Initialize ile verileri zaten alıyoruz. Alınan bu verilerin içerisinde tek olanları saydırsak ve sadece sayılan verileri label yardımı ile görüntülesek. Bana gerekli olan tek olanların sayısı ayrıca tek olanların görüntülenmesine gerek yok tüm listemin görüntülenmesi yeter yani 3500 (hergün artıyor) veri içerisinde 1200 civarında tek olan var ve ben bu tek olan sayısını Formu açtığımda görüntülemek istiyorum tabii beni kasmadan

Private Sub CommandButton1_Click()
Dim AllCells As Range, Cell As Range
    Dim ciftdegil As New Collection
    Dim i As Integer, j As Integer
    Dim Swap1, Swap2, Item
    Set AllCells = Range("E1:E65536")
        On Error Resume Next
    For Each Cell In AllCells
        ciftdegil.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    With UserForm1
              .Label1.Caption = "Benzersiz Öğe Sayısı : " & ciftdegil.Count
    End With
       For i = 1 To ciftdegil.Count - 1
        For j = i + 1 To ciftdegil.Count
            If ciftdegil(i) > ciftdegil(j) Then
                Swap1 = ciftdegil(i)
                Swap2 = ciftdegil(j)
                ciftdegil.Add Swap1, before:=j
                ciftdegil.Add Swap2, before:=i
                ciftdegil.Remove i + 1
                ciftdegil.Remove j + 1
            End If
        Next j
    Next i
    
    For Each Item In ciftdegil
        UserForm1.ListBox1.AddItem Item
    Next Item
        UserForm1.Show
End Sub

 

[Levent Menteşoğlu]

Hangi sütundaki veriler tekrarsız olarak sayılacaktır.

 

[noxious]

Hocam saygılar
E1:E65536 sütunundaki tek olanlar sayılacak.

Form açıldığında ListBox üzerine "A1:AV3510" arasında veri var ve bu veriler içerisinde "E" sütununda adresler mevcut ben yukardaki kod içerisinde "E" sütununa göre ayarlama yaptım ama bahsettiğim gibi önce sayıp sonra ListBox a veri aldığı için işlem çok uzun sürüyor ve hergün veri girişi yaparak listeyi şişirdiğimizden dolayı tek kayıt sayımızı merak ediyoruz.

Bize gerekli olan ListBox içerisine alınan veri içerisinde "E" Sütununda bulunan kayıtların tek olanlarının sayısını görmek

 

[Levent Menteşoğlu]

Aşağıdaki kodu denermisiniz.

son = [e65536].End(3).Row
MsgBox Evaluate("SUMPRODUCT((E1:E" & son & "<>" & """" & """" & ")/COUNTIF(E1:E" & son & _
",E1:E" & son & "&" & """" & """" & "))")

Not: Aşağıdaki linkte Sn Ali beyin önerdiği fonksiyonun koda çevrilmiş halidir.

Kaç adet farklı sayı var nasıl bulunur

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub listele()
Dim i As Long, toplam As Double
ListBox1.Clear
ReDim myarr(1 To 1, 1 To 1)
For i = 1 To Cells(65536, "E").End(xlUp).Row
    If Cells(i, "E").Value Mod 2 = 1 Then
        a = a + 1
        ReDim Preserve myarr(1 To 1, 1 To a)
        myarr(1, a) = Cells(i, "E").Value
        toplam = toplam + Cells(i, "E").Value
    End If
Next
ListBox1.Column = myarr
Label2.Caption = Format(toplam, "#,##0.00")
End Sub

Private Sub UserForm_Initialize()
Call listele
End Sub

 

[noxious]

Sayın Orion Hocam Leventm hocama cevap yazarken istediğim cevap sizden gelmiş teşekkürler.

sayın Leventm Hocam Orion Hocamın gönderdiği kodlar iş görüyor sizin kodlarınızda çok hızlı ikisi arasında kararsız kaldım. Sizin kodunuzu UserForm_Initialize içerisine ekledim ve açılışta önce MsjBox içerisinde sayıyı gösteriyor sonra Form açılıyor. Sizin kodunuzu bir button a eklesek ve sadece button u tıkladığımızda ..... sayısı kadar tek kayıt var dese mümkünmü acaba birde son olarak 1201.999999 olarak çıkıyor. 1202 kayıt var küsüratı yok edebilirmiyiz


Sonradan Farkettim Orion Hocam kodlar sayısal değerlerde okey ama metin oldumu sorun çıkıyor. Metin sayacak şekilde değiştirmek mümkünmü acaba

 

[noxious]

Sayın Orion Hocam ekte sadece E sütununda adresler var buna göre uyarlanabilirmi

 

[Levent Menteşoğlu]

Alternatif olarak aşağıdaki kodu deneyin.

Private Sub UserForm_Initialize()
For a = 1 To [e65536].End(3).Row
If WorksheetFunction.CountIf(Range("e1:e" & a), Cells(a, "e")) = 1 Then c = c + 1
Next
Label2 = c
End Sub

 

[noxious]

Hocam şimdi oldu açılış etkilenmiyor sadece 1,2 saniye beklemesi arttı ama bu bekleme de normal sayılır.

Tekrar çok teşekkürler. Saygılar

 

[Orion1]

Sanırım problem çözüldü.

 

[noxious]

Evet Orion2 Hocam Leventm Hocam sayesinde sorun halloldu ama sizde her zaman olduğu gibi bugünde ilgi ve alakanızı esirgemediniz sizede çok teşekkürler ve saygılar sunarım

 

[Orion1]

Evet Orion2 Hocam Leventm Hocam sayesinde sorun halloldu ama sizde her zaman olduğu gibi bugünde ilgi ve alakanızı esirgemediniz sizede çok teşekkürler ve saygılar sunarım

Rica ederim.
Saygılar bizden.