En çok tekrar eden metni makro ile bulmak

[osman1309]

Merhaba,

Excel formül ile en çok tekrar eden metni formül ile bulabiliyorum aynısını makroya vba fonksiyonuna çevirebilecek olan var mı?

=İNDİS(A2:A375;ENÇOK_OLAN(KAÇINCI(A2:A375;A2:A375;0)))

deger=Application.?(a2:a375;?(?((A2:A375;A2:A375;0))) gibi

 

[RBozkurt]

Merhaba, deneyiniz.

Sub EnCokTekrarEdenDeger()
    Dim ws As Worksheet
    Dim rng As Range
    Dim dict As Object
    Dim cel As Range
    Dim maxCount As Long
    Dim maxVal As Variant
    
    Set ws = ActiveSheet
    Set rng = ws.Range("A2:A375")
    Set dict = CreateObject("Scripting.Dictionary")

    For Each cel In rng
        If Trim(cel.Value) <> "" Then
            If Not dict.Exists(cel.Value) Then
                dict.Add cel.Value, 1
            Else
                dict(cel.Value) = dict(cel.Value) + 1
            End If
        End If
    Next cel

    maxCount = 0
    For Each Key In dict
        If dict(Key) > maxCount Then
            maxCount = dict(Key)
            maxVal = Key
        End If
    Next Key
    
    If maxCount > 0 Then
        MsgBox "En çok tekrar eden değer: " & maxVal & vbCrLf & "Tekrar sayısı: " & maxCount
    Else
        MsgBox "Veri aralığında hiç tekrar eden değer yok."
    End If
    
End Sub

 

[osman1309]

Merhaba, deneyiniz.

Sub EnCokTekrarEdenDeger()
    Dim ws As Worksheet
    Dim rng As Range
    Dim dict As Object
    Dim cel As Range
    Dim maxCount As Long
    Dim maxVal As Variant
  
    Set ws = ActiveSheet
    Set rng = ws.Range("A2:A375")
    Set dict = CreateObject("Scripting.Dictionary")

    For Each cel In rng
        If Trim(cel.Value) <> "" Then
            If Not dict.Exists(cel.Value) Then
                dict.Add cel.Value, 1
            Else
                dict(cel.Value) = dict(cel.Value) + 1
            End If
        End If
    Next cel

    maxCount = 0
    For Each Key In dict
        If dict(Key) > maxCount Then
            maxCount = dict(Key)
            maxVal = Key
        End If
    Next Key
  
    If maxCount > 0 Then
        MsgBox "En çok tekrar eden değer: " & maxVal & vbCrLf & "Tekrar sayısı: " & maxCount
    Else
        MsgBox "Veri aralığında hiç tekrar eden değer yok."
    End If
  
End Sub

Merhaba, İlgi ve alakanızdan dolayı çok teşekkür ederim. Bende farklı çözümler bulmuştum. Fikir açısından onları da paylaşıyorum. Anladığım kadarı ile tek satır fonksiyonla yapılamıyor.

Sub encok_gecen_bul_1()
'declare variables
Dim rng As Range
Dim selectrng As Range
Dim ws As Worksheet
Set ws = Worksheets("Sayfa1")
Set selectrng = Range("A2:A8296")
'return most frequently occurring text from a range
With CreateObject("scripting.dictionary")
For Each rng In selectrng
If rng.Value <> "" Then
.Item(rng.Value) = .Item(rng.Value) + 1
If .Item(rng.Value) > occur Then
occur = .Item(rng.Value)
freqtext = rng.Value
End If
End If

Next

ws.Range("E4") = freqtext
End With
End Sub

 

[Necdet]

Merhaba,
Alternatif olsun :

Sub Makro1()

Dim i As Long

i = Cells(Rows.Count, "A").End(3).Row

MsgBox Evaluate("=INDEX(A2:A" & i & ",MODE(MATCH(A2:A" & i & ",A2:A" & i & ",0)))")
 
End Sub

 

[osman1309]

Merhaba,
Alternatif olsun :

Sub Makro1()

Dim i As Long

i = Cells(Rows.Count, "A").End(3).Row

MsgBox Evaluate("=INDEX(A2:A" & i & ",MODE(MATCH(A2:A" & i & ",A2:A" & i & ",0)))")

End Sub

Her ikinize de emeğinizden dolayı çok çok teşekkür ederim. Allah razı olsun.