unique süzme

[goklerhakimi]

Merhaba,

saatlerdir aradım ama bulamadım. makroda otomatik süzme yaparken "unique" secenegini kullanmak istiyorum. ekteki dosyada ilk sayfadaki bilgilieri unique filter ile süzdükten sonra ikinci sayfada saydırdım. bunu makro ile nasıl yapabilirim?

 

[Korhan Ayhan]

Selamlar,

Bu türde tablolarınızı düzenlemek için ÖZET TABLO kullanmanızı tavsiye ederim. Ekteki örnek dosyanızda hem ÖZET TABLO ile hemde MAKRO ile ilgili çözümleri bulabilirsiniz.

 

[goklerhakimi]

çabanız için teşekkürler COST_CONTROL. ama net ifade edememişim galiba. aradığım pivot table ya da unique filter ile yapılan bir şey değil de döngülerle kurmaya çalışmak. bu kısım, yazmaya çalıştığım daha büyük bir makronun küçük bir kısmını oluşturacak.

 

[Skorpiyon]

Sayın goklerhakimi,

Ekli dosyayı inceleyiniz. Sanırım böyle bir şey istiyorsunuz.

Not : Sayfa1 benim eklediğim, sonuc sizinki. Düğmeye bastıktan sonra çıkan sonucu görmeniz için.

Saygılarımla.

 

[goklerhakimi]

teşekkürler Sertkaya, verdiğiniz kod işime yarayacak gibi

 

[Recep İpek]

Alternatif olarak aşağıdaki kodları deneyiniz.

Sub AktarSay()
Dim a, n As Long, i As Long, z As Object
Set s1 = Sheets("ana")
Set s2 = Sheets("sonuc")
Application.ScreenUpdating = False
s2.Range("a2:b500").ClearContents
'*******************************************************
a = s1.[a2:a500]
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
    If Not z.exists(a(i, 1)) Then
        z.Add a(i, 1), 1
    Else
        z.Item(a(i, 1)) = z.Item(a(i, 1)) + 1
    End If
Next i
s2.[a2].Resize(z.Count - 1, 2) = Application.Transpose(Array(z.keys, z.items))
'*******************************************************
Application.ScreenUpdating = True
MsgBox "Bitti"
Set z = Nothing
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Orion1]

Sayın Ripek hocam ,bu kodlarla a2:b sütununda süzüp listeleme yapabiliyoruz.
Fakat çalışma sayfasına değilde listbox'ta nasıl gösterebiliriz?
Saygılar..

 

[Recep İpek]

Bunun gibi mi?

 

[Recep İpek]

Veya

Dim r As Ragne 
With CreateObject("Scripting.Dictionary") 
     .CompareMode = vbTextCompare 
     For Each r In Sheets("sheet1").Ragne("a1:a100")   
       If Not .exists(r.Value) Then .add r.Value, Nothing 
     Next 
     ListBox1.List = .keys 
End With

 

[Orion1]

Bunun gibi mi?

Evet sayın hocam.Teşekkür ederim.
Bununla ilgili müsaade ederseniz bir şey dağa sormak istiyorum.
Yalnızca mükerrer kayıtları listeleyebilirmiyiz?
Teşekkür ederim.

 

[Recep İpek]

İstediğiniz sadece mükerrer olan kayıtlar ise kodları aşağıdaki gibi değiştirin.

Private Sub CommandButton1_Click()
Dim a, n As Long, i As Long, z As Object
Set s1 = Sheets("ana")
'*******************************************************
a = s1.[a2:a500]
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
    If Not z.exists(a(i, 1)) Then
        z.Add a(i, 1), 1
    Else
        z.Item(a(i, 1)) = z.Item(a(i, 1)) + 1
    End If
Next i
For Each vKey In z.keys
    If z.Item(vKey) = 1 Then
        z.Remove (vKey)
    End If
Next vKey
With Me.ListBox1
    .Clear
    .ColumnCount = 2
    .ColumnWidths = "50;30"
    .List() = Application.Transpose(Array(z.keys, z.items))
End With
'*******************************************************
Set z = Nothing
Set s1 = Nothing
End Sub

 

[Orion1]

Sayın hocam ,Teşekkür ederim.
Bu konu ile son bir soru.
A'dan C sütununa kadar verilerim var,A sütununda mükerrer olan ve olmayan değerlerim var.
A sütununda benzersiz kayıtları bulup,A B ve C sütunundaki bilgileri listbox'a nasıl akatarbilirim?

 

[Recep İpek]

Aşağıdaki kodları deneyebilirmisiniz.

Sub Deneme01()
Dim a, i As Long, b(), c(), n As Long

With ActiveSheet.Range("a1").CurrentRegion.Resize(, 3)
     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 = [b]1[/b] To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               n = n + 1
               b(n, 1) = a(i, 1)
               b(n, 2) = a(i, 2)
               .Add a(i, 1), n
          End If
          b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + 1
     Next
End With

For i = 1 To UBound(b, 1)
    If b(i, 3) = 1 Then
        s = s + 1
        c(s, 1) = b(i, 1)
        c(s, 2) = b(i, 2)
        c(s, 3) = b(i, 3)
    End If
Next i
With Me.ListBox1
    .Clear
    .ColumnCount = 3
    .ColumnWidths = "60;60;50"
    .List() = c
End With
'With ActiveSheet.Range("f1")
     '.Resize(, 3).EntireColumn.ClearContents
     '.Resize(n, 3).Value = c
'End With
End Sub

 

[Orion1]

Merhaba.
Sayın hocam, Teşekkür ederim.1nci satırda Mükerrer kayıt olduğu halde onuda gösteriyor.
Ekli dosyada gösterdim.Sarı renkli satırlar benzersiz kayıtlar.
Onları listelemiş bir tanede 1nci satırdaki mükerrer kayıtlardan listelemiş.
Saygılar.

 

[Recep İpek]

İlgili kod revize edilmiştir.Bold olan yeri değiştirmeniz yeterlidir.

 

[Orion1]

Sayın hocam teşekkür ederim.
Birde Bu işlemi listbox'ta nasıl listeleriz?
Onuda yazarsanız benim bu konuda soracağım başka bir şey olmayacaktır diye düşünüyorum.

 

[Recep İpek]

Ekli dosyayı inceleyin.

 

[Orion1]

Merhaba.
Sayın hocam teşekkür ederim.
İyi geceler.