Tekrar Eden Sayılar

[GAZOZ_55]

Arkadaşlar merhaba,

Aşağıda sayılar ve sayıların kaç defa tekrar etmesi gerektiği yazılmıştır. Bunu yapacak VBA kod nedir? Ben denedim ancak olmadı.

10 10 2
10 20 3
20 30 4
20
20
30
30
30
30

 

[Ömer]

Merhaba,

Deneyiniz.

Sub ozet_say()

    Dim d As Object, i As Long, deg, son As Long

    Set d = CreateObject("Scripting.Dictionary")
    son = Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For i = 1 To son
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, 1
        Else
            d.Item(deg) = d.Item(deg) + 1
        End If
    Next i
 
    Range("B:C").ClearContents
    Range("B1").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))

End Sub

 

[GAZOZ_55]

Ömer bey çok teşekkür ederim cevap verdiğiniz için ancak kodu çalıştırdığımda sonuç çıkmadı.

 

[Ömer]

Örnek dosya ekler misiniz.

 

[GAZOZ_55]

Ekteki gibi.

 

[GAZOZ_55]

Dosya ektedir.

 

[Ömer]

Denedim, verdiğim kodlar bu sonuçları alıyor, sonuç alamadığınız dosyayı eklerseniz, inceleyip dönüş yaparım.
B yerine C de listelenmesi için:

Sub ozet_say()

    Dim d As Object, i As Long, deg, son As Long

    Set d = CreateObject("Scripting.Dictionary")
    son = Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For i = 2 To son
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, 1
        Else
            d.Item(deg) = d.Item(deg) + 1
        End If
    Next i
 
    Range("C2:D" & Rows.Count).ClearContents
    Range("C2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))

End Sub

 

[Ömer]

Dosya ektedir.

Herhangi bir sorun göremedim, kodlar çalışıyor. Eki inceleyin.

 

[GAZOZ_55]

Hocam kusura bakmayın benim hatam. Nasıl olacağını söylemedim. Sayı ve tekrar yazan kısım data olacak, o dataya göre sonuç kısmına sonucu yazdıracak. Data kısmı 3 satır yada 10 satır da olabilir.

 

[Ömer]

Deneyiniz.

Sub dagit()

    Dim i As Long, sat As Long, son As Long
    
    son = Cells(Rows.Count, "C").End(xlUp).Row

    Application.ScreenUpdating = False
    Range("A2:a" & Rows.Count).ClearContents
    
    sat = 2
    For i = 2 To son
        Cells(i, "C").Copy Cells(sat, "A").Resize(Cells(i, "D"), 1)
        sat = sat + Cells(i, "D")
    Next i

End Sub

 

[veyselemre]

Sub test()
    son = Cells(Rows.Count, "C").End(xlUp).Row
    Range("a2:a" & Rows.Count).ClearContents
    sat = 2
    For i = 2 To son
        deg = Cells(i, "C")
        kac = Cells(i, "D")
        Cells(sat, 1).Resize(kac, 1).Value = deg
        sat = sat + kac
    Next i
End Sub

 

[GAZOZ_55]

Ömer bey ve Veysel bey çok teşekkür ederim. İki kodda sorunsuz çalışıyor. Ellerinize sağlık.
Şimdi soracağım soruyu başka bir başlıkta mı yoksa buraya mı yazayım bilemedim.
Ancak soru şu ki üretilen bu sayıların birbiriyle 2'li, 3'lü ve 4'lü kombinasyonlarını yapmak istiyorum. Acaba bu mümkün mü?