Aynı kayıtların sayısını ver

[arch_koven]

Arkadaslar A1:A5000 hücreleri arasında sayılar bulunmakta.
Bu bu sayılardan en çok tekrar eden ilk 5 sayıyı ve ne kadar tekrar ettiklerini command buton ile buldurmam gerekiyor. Bu konu hakkında nasıl bir yol izlemem gerektiği konusunda fikir verebilcek olan var mı aranızda. Çalışmalarınızda başarılar.

 

[leumruk]

Merhaba,
Örnek dosyayı deneyiniz. Eklediğim kod tekrar eden sayıları tekrar sayısıyla birlikte listeliyor. Siz beş tanesini istemişsiniz. İsterseniz kodun sonuna silme kodu ekleyerek sayı miktarını beşe düşürebiliriz.

Sub Tekrar()
Sat = 2
For x = 1 To [a65536].End(3).Row
Say = WorksheetFunction.CountIf([C:C], Cells(x, "a"))
If Say = 0 Then
Say = WorksheetFunction.CountIf([A:A], Cells(x, "a"))
If Say > 1 Then
Cells(Sat, "c") = Cells(x, "a")
Cells(Sat, "d") = Say
Sat = Sat + 1
End If
End If
Next
Range("c1:d" & [c65536].End(3).Row).Sort Key1:=Range("D1"), Orientation:=xlTopToBottom
End Sub

 

[fedeal]

form üzerinde bir örnekte ben yaptım;

 

[Orion1]

Sub tekrar()
Dim i As Integer, a As Integer, j As Integer, x As Variant
ReDim myarr(1 To 2, 1 To 1)
For i = 1 To 5000
    If WorksheetFunction.CountIf(Range("A1:A" & i), Cells(i, "A").Value) = 1 Then
        a = a + 1
        ReDim Preserve myarr(1 To 2, 1 To a)
        myarr(1, a) = Cells(i, "A").Value
        myarr(2, a) = WorksheetFunction.CountIf(Range("A1:A5000"), Cells(i, "A").Value)
    End If
Next i
For i = LBound(myarr, 2) To UBound(myarr, 2) - 1
    For j = i + 1 To UBound(myarr, 2)
        If myarr(2, i) < myarr(2, j) Then
            For z = 1 To 2
                x = myarr(z, i)
                myarr(z, i) = myarr(z, j)
                myarr(z, j) = x
            Next z
        End If
    Next j
Next i
deg = "Sayı" & " " & "      Miktar"
deg = deg & vbLf & "---------" & " " & "---------"
For i = 1 To 5
deg = deg & vbLf & myarr(1, i) & "        =        " & myarr(2, i)
Next i
MsgBox deg
End Sub

 

[arch_koven]

Süpersiniz sayın leumruk, fedeal ve evren_gizlen
Elleriniz dert görmesin. Çalışmalarınızda başarılar