Otomatik Sayma ve Gruplama

[dreaviman]

Arkadaşlar bir sutundaki değerleri otomatik olarak sayan ve gruplayan bir program yapmak istiyorum örnekte daha iyi anlaşılacaktır. Cevaplarınız bekliyorum

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub mukerrer()
Dim a, i As Long, z As Object
Range("B2:C65536").ClearContents
Set z = CreateObject("scripting.dictionary")
a = Range("A1:A" & Cells(65536, "A").End(xlUp).Row)
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
[B2].Resize(UBound(z.keys, 1), 2) = Application.Transpose(Array(z.keys, z.items))
MsgBox "İŞLEM TAMAMLANDI..!!", vbOKOnly + vbInformation, "EVREN"
End Sub

 

[dreaviman]

eline sağlık orion2 tam istedeğim gibi olmuş

 

[Orion1]

eline sağlık orion2 tam istedeğim gibi olmuş

Rica ederim.
İyi çalışmalar.

 

[N.Ziya Hiçdurmaz]

Yanıt

Sayın Orion2 cevaplamış buda örnek olması açısından daha basit kodlama ile elde edilen sonuç.

Sub TEKRARLANANLAR()
Dim SUT, S, SUTB As Integer
[B2:C65536].Clear
For SUT = 1 To Cells(65536, "A").End(3).Row
If WorksheetFunction.CountIf(Range("A1:A" & SUT), Cells(SUT, "A")) = 1 Then
S = S + 1
Cells(S + 1, "B") = Cells(SUT, "A").Value
End If
Next
For SUT = 1 To Cells(65536, "A").End(3).Row
For SUTB = 2 To 8
If Cells(SUT, "A") = Cells(SUTB, "B") Then
Cells(SUTB, "C") = Cells(SUTB, "C") + 1
End If
Next
Next
End Sub

 

[Ali]

Formüllü örnek ektedir.

 

[dreaviman]

arkadaşlar hepinize teşekkürler çok işime yarıyacak