VBA help to identify most frequently occurring text

[Legacy 462862]

Hi,

I've used the following to identify the most frequently occurring text in my sheet:

- - -

Function Freq(rng As Range) As String

Dim cll As Range
Dim lngCount As Long
Dim lngMax As Long
Dim str As String

Set dic = CreateObject("scripting.dictionary")

On Error Resume Next

For Each cll In rng

If cll.Value <> "" Then
dic(cll.Value) = dic(cll.Value) + 1
lngCount = dic(cll.Value)
If lngCount > lngMax Then
lngMax = lngCount
str = cll.Value
End If
End If
Next

On Error GoTo 0

Freq = str

End Function

- - -

Does anyone know what needs to be changed to identify the 2nd, 3rd, 4th, 5th etc? Or a different way of doing it?

Thanks!

 

[Fluff]

Without being able to see your data, there's nothing much I can do unfortunately.

 

[Legacy 462862]

No problem, thanks for your help so far.

The code in post 26 pulls the right names but has the wrong numerical value. Is there a way of just pulling the names?

 

[Fluff]

Yup, you can use

Sub zoersdn()
   Dim Ary As Variant, Kth As Variant
   Dim r As Long, i As Long, NxtRw As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Dic.CompareMode = 1
   Ary = Range("N11:X21").Value2
   NxtRw = UBound(Ary) + 10
   
   For r = 2 To UBound(Ary)
      For i = 1 To UBound(Ary, 2)
         If Ary(r, i) <> "" Then
            Dic(Ary(r, i)) = Dic(Ary(r, i)) + 1
         End If
      Next i
   Next r
   ReDim Ary(1 To Dic.Count, 1 To 2)
   Kth = Application.Large(Dic.Items, 10)
   If IsError(Kth) Then Kth = Application.min(Dic.Items)
   r = 0
   
   For i = 0 To Dic.Count - 1
      If Dic.Items()(i) >= Kth Then
         r = r + 1
         Ary(r, 1) = Dic.Keys()(i)
      End If
   Next i
   Range("N" & NxtRw).Resize(r).Value = Ary
End Sub

 

[Legacy 462862]

Sub zoersdn() Dim Ary As Variant, Kth As Variant Dim r As Long, i As Long, NxtRw As Long Dim Dic As Object Set Dic = CreateObject("scripting.dictionary") Dic.CompareMode = 1 Ary = Range("N11:X21").Value2 NxtRw = UBound(Ary) + 10 For r = 2 To UBound(Ary) For i = 1 To UBound(Ary, 2) If Ary(r, i) <> "" Then Dic(Ary(r, i)) = Dic(Ary(r, i)) + 1 End If Next i Next r ReDim Ary(1 To Dic.Count, 1 To 2) Kth = Application.Large(Dic.Items, 10) If IsError(Kth) Then Kth = Application.min(Dic.Items) r = 0 For i = 0 To Dic.Count - 1 If Dic.Items()(i) >= Kth Then r = r + 1 Ary(r, 1) = Dic.Keys()(i) End If Next i Range("N" & NxtRw).Resize(r).Value = Ary End Sub

Thanks!

 

[Fluff]

You're welcome.