Döngü İçerisinde Tekrarlananların Sayısını Yazma

[oguzka]

Merhabalar;

Aşağıda kodlarını yazdığım döngü ile oDat adı ile oluşturduğum datasetteki herbir nesnesinin değerini bir hücreden başlayarak alt alta yazdırıyorum. Yapmak istediğim şu ki, değeri aynı olanları (mükerrer bilgi) bir kere yazdırıp yanına da bu nesneden kaç adet varsa onun sayısını yazdırayım. Nasıl yapabilirim? Tüm nesneleri diziye alarak yapmaya çalıştım ancak başarılı olamadım. Yardım edermisiniz.




'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Each oEnt In oDat

Set oText = oEnt

ActiveSheet.Cells(ActiveCell.row, ActiveCell.Column).Value= oText.textString
ActiveSheet.Cells(ActiveCell.row + 1, ActiveCell.Column).Select

End If
Next oEnt

 

[Ömer]

Merhaba,

Bunun için farklı ve çok daha hızlı olan "Scripting.Dictionary" nesnesi ile işlem yapmak bence daha doğru olacaktır.

Küçük bir örnek dosya ekleyerek kodları sorunuzu açıklarmısınız.

 

[oguzka]

Ömer Bey, örnek dosya ekleyecektim en başında ancak dosyam farklı bir programdan veri alarak dataseti oluşturuyor. Dolayısıyla diğer programında herkesde olamayacağını düşünerek koddaki sadece ilgili kısmı yazdım mesajımda.

 

[Ömer]

Kendi dosyanızı eklemenize gerek yok, veri düzeniyle ilgili 15-20 satırlık basit bir dosya ekleyip dosya içerisinde olması gereken düzeni bize açıklamanız yeterlidir.

 

[oguzka]

Ömer Bey veri düzeninin nasıl olması ile ilgili örnek dosyayı ekledim. Datasete veri almak ile ilgili kodu ekleyemedim. Veriyi başka yerden aldığı için örnek birşey kodlayamadım. Umarım yardımcı olur.

 

[Ömer]

Bu şekilde deneyin.

Sub OzetAl()
    
    Dim d As Object, i As Long, sat As Long, a1, a2, s, deg
    
    Set d = CreateObject("Scripting.Dictionary")
    
    Range("F4:G" & Rows.Count).ClearContents
    
    For i = 4 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            s = Cells(i, "C")
            d.Add deg, s
        Else
            s = d.Item(deg)
            s = s + Cells(i, "C")
            d.Item(deg) = s
        End If
    Next i
 
    a1 = d.keys: a2 = d.items: sat = 4
    For i = 0 To d.Count - 1
        Cells(i + sat, "F") = a1(i)
        Cells(i + sat, "G") = a2(i)
    Next i
 
End Sub

.

 

[oguzka]

Ömer bey gecikmiş bir cevap oldu ama kusura bakmayın. Çok teşekkür ederim.