Tekrarlanan sayıları büyükten küçüğe sıralamak.

[Filose]

Herkese merhaba,

Ekte bulunan dosya örneğinde, Makro ile aynı sayfada bulunan tekrarlanan sayıları bulup ve kaçar defa tekrarlandığı konusunda yardımcı olabilirmisiniz. Bu konu ile ilgili burada bulunan yardımcı kaynaklardan da becerip bir araya getiremedim.

Saygılar.

 

[Korhan Ayhan]

Ofis 365 için fonksiyonla çözüm.. Forumun arşivinde bulunmasaı açısından paylaşıyorum.

M8;

=SIRALA(BENZERSİZ(XMLFİLTRELE("<a><b>"&YERİNEKOY(METİNBİRLEŞTİR("|";1;E8:G58);"|";"</b><b>")&"</b></a>";"//b"));;-1)

N8;

=EĞERSAY($E$8:$G$58;M8)

Makrolu 3 alternatif çözüm...

Option Explicit

Sub Test_1()
    Dim Rng As Range

    Range("M8:N58").ClearContents

    With CreateObject("System.Collections.ArrayList")
        For Each Rng In Range("E8:G58")
            If Rng.Value <> "" Then
                If Not .Contains(Rng.Value) Then .Add Rng.Value
            End If
        Next
        .Sort
        .Reverse
        Range("M8").Resize(.Count) = Application.Transpose(.ToArray())
        Range("N8").Resize(.Count) = "=COUNTIF(E$8:G$58,M8)"
        Range("N8").Resize(.Count).Value = Range("N8").Resize(.Count).Value
    End With
End Sub

Sub Test_2()
    Dim Rng As Range
 
    Range("M8:N58").ClearContents

    With CreateObject("Scripting.Dictionary")
        For Each Rng In Range("E8:G58")
            If Rng.Value <> "" Then
                .Item(Rng.Value) = .Item(Rng.Value) + 1
            End If
        Next

        Range("M8").Resize(UBound(Application.Transpose(.Keys)), 2) = Application.Transpose(Array(.Keys, .Items))
        Range("M8:N58").Sort Range("M8"), xlDescending
    End With
End Sub


Sub Test_3()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String

    Range("M8:N58").ClearContents
  
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
  
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    My_Query = "Select F4 From [Sayfa1$B8:G58] Where Not IsNull(F4) Union " & _
               "Select F5 From [Sayfa1$B8:G58] Where Not IsNull(F5) Union " & _
               "Select F6 From [Sayfa1$B8:G58] Where Not IsNull(F6) Order By F4 Desc"
      
    My_Recordset.Open My_Query, My_Connection, 1, 1
    Range("M8").CopyFromRecordset My_Recordset
    Range("N8").Resize(My_Recordset.RecordCount) = "=COUNTIF(E$8:G$58,M8)"
    Range("N8").Resize(My_Recordset.RecordCount).Value = Range("N8").Resize(My_Recordset.RecordCount).Value

    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
  
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
End Sub

 

[veyselemre]

Örnek olsun.

Sub adoUnionAll()
    Dim rs As Object, con$, strSQL$

    Range("M8:P58").ClearContents
    Set rs = CreateObject("ADODB.Recordset")
 
    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=No"""
       
    strSQL = "SELECT F1, COUNT(F1) AS ADET, '', F1 * ADET FROM " & _
             "( SELECT F1 FROM [Sayfa1$E8:E58] UNION ALL " & _
             "  SELECT F1 FROM [Sayfa1$F8:F58] UNION ALL " & _
             "  SELECT F1 FROM [Sayfa1$G8:G58]           ) " & _
             "WHERE NOT F1 IS NULL GROUP BY F1 ORDER BY F1 DESC "

   'strSQL = "SELECT F1, COUNT(F1) AS ADET, '', F1 * ADET FROM " & _
             "( SELECT F1       FROM [Sayfa1$E8:G58] UNION ALL " & _
             "  SELECT F2 AS F1 FROM [Sayfa1$E8:G58] UNION ALL " & _
             "  SELECT F3 AS F1 FROM [Sayfa1$E8:G58]           ) " & _
             "WHERE NOT F1 IS NULL GROUP BY F1 ORDER BY F1 DESC "
     
    rs.Open strSQL, con, 1, 1
 
    Range("M8").CopyFromRecordset rs
 
    rs.Close
End Sub

 

[Filose]

Sayın Korhan Bey ve Veysel Emre Bey,

İlginiz ve emeğiniz için çok teşekkür ediyorum. Kodlar çalıştı tam istediğim gibi oldu. Sadece Korkan Beyin Test_1 kodu hata verdi. Bunun da önemi yok diğer kodlar çalışıyor. İyi ki varsınız.

Saygı ve hürmetle,

 

[Korhan Ayhan]

Test_1 kodunun çalışması için sisteminizde Microsoft .NET Framework 3.5 sürümünün yüklü olması gerekiyor. Daha üst sürümlerin yüklü olması maalesef yeterli gelmiyor.

Ayrıca Test_2 kodunda küçük bir revize yaptım. Gereksiz bir satırı sildim.

 

[Filose]

Korhan Bey, ellerinize sağlık çok teşekkür ediyorum.
Hürmetle,