[ÇÖZÜLDÜ] Mükerrer isimlerin userformda görünmesini sağlamak..

[enteresan]

Sevgili excel severler, kullanmakta olduğum dosyada bir sütundaki tekrarlanan değerleri userform üzerinde tek kayıt olarak görmek istiyorum. Yani bir nevi süzme işlemi yapılacak. Birden fazla tekrarlayan isimleri tek olarak alacak ve sağına da kaç kez tekrarlandığı yazılacak. Bu şekilde bir kod mümkün mü? İlgilenenlere teşekkür ederim....

 

[Recep İpek]

Aşağıdaki kodları kullanabilirsiniz.

Private Sub UserForm_Initialize()
Dim a, i As Long, b(), n As Long

With Range("c2:c" & [c65536].End(3).Row)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 3)
End With

With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               n = n + 1
               b(n, 1) = n  'Sıra No
               b(n, 2) = a(i, 1) 'İl Adı
               .Add a(i, 1), n
          End If
          b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + 1 ' Sayısı
     Next
End With

With Me.ListBox1
    .Clear
    .ColumnCount = 3
    .ColumnWidths = "20;75;20"
    .List() = b
End With
End Sub

 

[Mahmut Kök]

Bir örnek hazırladım. Forma bir adet liste kutusu (listbox) bir adet de düğme ekleyin ve aşağıdaki kodu, düğmeye atayarak deneyebilirsiniz.

Private Sub CommandButton1_Click()
ListBox1.ColumnCount = 2
For c = 2 To [c65536].End(3).Row
il = Cells(c, "c")
    For l = 0 To ListBox1.ListCount - 1
    If ListBox1.List(l) = il Then GoTo atla
    Next
ListBox1.AddItem Cells(c, "c")
   ListBox1.List(x, 1) = WorksheetFunction.CountIf(Range("c1:c65536"), il)
x = x + 1
atla:
Next
End Sub

 

[Orion1]

Ekli dosyayı incelyiniz.
Userform'un General bölümüne aşağıdaki kodları.(Alfabetik sıralama yapmak için)

Private Function Sirala(Liste As Variant)
Dim i As Integer, j As Integer, x As Variant
    For i = LBound(Liste) To UBound(Liste) - 1
        For j = i + 1 To UBound(Liste)
            If StrComp(Liste(i, 0), Liste(j, 0), vbTextCompare) = 1 Then
                x = Liste(j, 0)
                Liste(j, 0) = Liste(i, 0)
                Liste(i, 0) = x
            End If
        Next j
    Next i
    Sirala = Liste
End Function

Initialize olayına aşağıdaki kodu yazınız.

Private Sub UserForm_Initialize()
Dim i As Long
Sheets("Sayfa1").Select
For i = 2 To Cells(65536, "C").End(xlUp).Row
    If Cells(i, "D").Value <> "" And Cells(i, "D").Value > 1 Then
        ListBox1.AddItem Cells(i, "C").Value
    End If
Next i
Liste = ListBox1.List
ListBox1.List = Sirala(Liste)
End Sub

 

[Mahmut Kök]

Eğer formunuza bir adet listview ekler ve bir düğmeye aşağıdaki kodu tanımlarsanız, listeniz listviewde daha görsel ve sıralı bir şekilde listelenir.

ListView1.View = lvwReport
ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear
ListView1.ColumnHeaders.Add , , "il"
ListView1.ColumnHeaders.Add , , "kayıt sayısı"
For c = 2 To [c65536].End(3).Row
il = Cells(c, "c")
    For l = 1 To ListView1.ListItems.Count
    If ListView1.ListItems(l) = il Then GoTo atla
    Next
x = x + 1
ListView1.ListItems.Add , , Cells(c, "c")
   ListView1.ListItems(x).SubItems(1) = WorksheetFunction.CountIf(Range("c1:c65536"), il)
atla:
Next
ListView1.Sorted = True
ListView1.SortOrder = 1
ListView1.SortKey = 1
ListView1.Sorted = False

 

[enteresan]

Sayın Ripek, Sayın Mesleki ve Sayın orion2
Her üçünüze de çok teşekkür ederim. Değişik alternatifler sunmuşsunuz. Listbox'a alırken, sadece tekrarlayan isimleri ve sağına da kaç kez tekrarlandığını almasını istemiştim. Bu şekilde bir düzenleme yapılabilir mi. Yani 1 kez yazılan ismi listeye almasına gerek yok. Saygılarımla....

 

[Orion1]

Sayın Ripek, Sayın Mesleki ve Sayın orion2
Her üçünüze de çok teşekkür ederim. Değişik alternatifler sunmuşsunuz. Listbox'a alırken, sadece tekrarlayan isimleri ve sağına da kaç kez tekrarlandığını almasını istemiştim. Bu şekilde bir düzenleme yapılabilir mi. Yani 1 kez yazılan ismi listeye almasına gerek yok. Saygılarımla....

Ekli dosyayı inceleyiniz.
D sütunundaki formülleri istediğiniz kadar çoğaltabilirsiniz.

 

[Recep İpek]

Kodları aşağıdaki şekilde revize ediniz.

Private Sub UserForm_Initialize()
Dim a, i As Long, b(), c(), n, s As Long

With Range("c2:c" & [c65536].End(3).Row)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 3)
     ReDim c(1 To UBound(a, 1), 1 To 3)
End With

With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               n = n + 1
               b(n, 1) = n  'Sıra No
               b(n, 2) = a(i, 1) 'İl Adı
               .Add a(i, 1), n
          End If
          b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + 1 ' Sayısı
     Next
End With

For i = 1 To UBound(b, 1)
    If b(i, 3) > 1 Then
        s = s + 1
        c(s, 1) = s
        c(s, 2) = b(i, 2)
        c(s, 3) = b(i, 3)
    End If
Next i

With Me.ListBox1
    .Clear
    .ColumnCount = 3
    .ColumnWidths = "20;50;20"
    .List() = c
End With
End Sub

 

[enteresan]

Sevgili Orion2 ve Ripek, her ikinize de teşekkür eder, saygılar sunarım. Ayrıca Bayramınızı da kutlar, size ve ailenize sağlıklı ve mutlu nice bayramlar temenni ederim. Saygılarımla...