return the top occuring values in a list

[zest1]

Is there a formula or code that can return the values having the most (say 5 or 10, or perhaps user-defined) number of occurences in a list? Auto-Filter can return the top 10 values, but I want the top occurances, regardless of value.

[acw]

Hi

Are the values being counted numeric, alpha or alpha-numeric?


Tony

[zest1]

the values are numeric.

[Bob Phillips]

One way, assuming numbers are in A1:A20

B1:=A1
B2: =IF(ISERROR(MATCH(0,COUNTIF(B$1:B1,$A$1:$A$200&""),0)),"",
INDEX(IF(ISBLANK($A$1:$A$200),"",$A$1:$A$200),MATCH(0,COUNTIF(B$1:B1,$A$1:$A$200&""),0)))

which is an array formula, it should be committed with Ctrl-Shift-Enter, not just Enter.

Copy B2 down to B20

C1: =IF($B$1:$B$20<>"",COUNTIF($A$1:$A$20,$B$1:$B$20),"")
copy down to C20

You can then use conditional formatting in column B with a formula of =AND(C1<>"",C1>=LARGE($C$1:$C$20,5)) to pick out the most frequent.

[Shazam]

See if this works.


Say if your list starts in cell A2. Then in input this formula in cell B2:

=IF(SUM(COUNTIF($B$1:B1,$A$2:$A$100))=COUNTA($A$2:$A$100),"",INDEX(A2:$A$100,MATCH(0,--ISNUMBER(MATCH(A2:$A$100,$B$1:B1,0)),0)))

and copy it down.




Then input this formula in cell C2:

=IF(B2="","",LARGE(COUNTIF(A:A,B$2:B$12),ROW()-1))

and copy it down.


Both formulas need to be confirmed with:

CTRL+SHIFT+ENTER

[zest1]

Thanks a lot XLD and Shazan!

Both are great solutions.

One thing though, my lists are quite long, and I should probably use a VBA approach so as not to add any more to the file sizes.

Can you guys convert the above formulas to VBA, where I can then use a command button to exacute the code?

Thanks again

[acw]

Hi

Another approach would be to use the FREQUENCY function. You will have to determine a unique list of the numbers (many ways to do that), then use frequency to determine the counts per number. Then using the RANK formula along with INDEX / MATCH, you can extract the numbers for as many as required.


Tony

[zest1]

One thing I should have mentioned is that there are other cells/columns related to the list being checked for top occurences, and I'd like to have all of those cells copied over to another location as well (like Advanced Filter). How do I do that?

Using Shazam's example file, I added a couple columns to show what I mean. VBA or UDF would be fine too.

Tony, I'm not familiar with the Frequency or Rank functions - can you kindly give me an example.

Thanks

[jindon]

Sub test()
Dim dic As Object, a
Set dic = CreateObject("scripting.dictionary")
a = Range("c2", Range("c" & Rows.Count).End(xlUp)).Value
For Each e In a
If Not IsEmpty(e) Then
If Not dic.exists(e) Then
dic.Add e, 1
Else
dic(e) = dic(e) + 1
End If
End If
Next
Range("k2").Resize(dic.Count) = _
Application.Transpose(dic.keys)
Range("l2").Resize(dic.Count) = _
Application.Transpose(dic.items)
Set dic = Nothing: Erase a
End Sub

[zest1]

Thanks a lot for your code, Jindon.

And thanks again to everyone for providing me several approaches that I can use for other similar functions.

[zest1]

Shazam,

I discovered a problem with your code and am hoping you can tell me how to fix it. It seems that the code has a problem with the first number in the list - it always places that first number on the top of the 'Occuring" list even if it is not the most occuring. Any ideas as to how to correct this? (see your attachment)

Jindon,
I tried to use your code but need some guidance, if you don't mind.

XLD,
your code works great, but it doesn't sort the list in most-occuring to least occuring, which I would prefer. The sort function doesn't work on it since the cells contain formulas rather than values. Is there a way to sort the list in order of occurence (in descending order - most occuring on top)?

Thanks a lot.

[jindon]

1) hit Alt + F11 to open vb editor
2) go to [Insert] -> [Module] then paste the code there
3) click x to close the window to get back to Excel
4) select the sheet in question then go to [Tools]->[Macro]->[Macros] and choose test thenhit Run

"test" was assinged to commandbutton in the attached

[acw]

Zest

Just caught up with this.

I've put in examples of the Frequency, rank and extracting based on a "unique" ranking process.

Tony

[zest1]

Been away a few days.

Thanks a lot, ACW (Tony)!
That's great. Is there any way to sort the list by UniqRank or Top10 (an error pops up ("you cannot change part of an array") when I try to sort.


Thank you too, Jindon.
I know how to use vba, but the code was somehow not working before, but is works fine now.

One thing though, I have a few columns I'd like to apply your code to, and be able to rank and sort each one by 'Unique', or 'Occuring'. Is there a way to do that? Can you please tell me what changes I need to make to the code?

Thanks again for both your help.

[Shazam]

Hopefuly I got this right. See the attachment below.

[zest1]

Your formula works great, Shazam.

Except, when I changed the list's cell references to a dynamic named range, the formula calculates only the first few values in the list, instead of the entire list. Any ideas why that is, and what's needed?

Thanks for your help.

[acw]

Zest1

The top 10 is sorted in order of frequency. How do you want this listing sorted? I thought that was the way you wanted them to appear.


Tony

[Shazam]

See if this will do.

I named the formula box List
=OFFSET(Table!$A$2,,,COUNTA(Table!$A$2:$A$65536))


Attachment below.

[jindon]

Zest1
if your have multiple columns of data and if it is consecutive

just change


a = Range("c2", Range("c" & Rows.Count).End(xlUp)).Value
to


a = Range("c2", Range("c" & Rows.Count).End(xlUp)).resize(,2).Value
resize(,2) expand one more column ,3 to 2 more, 4 to 3 more and so forth

if you have separate columns then try


Sub test2()
Dim dic As Object, a, myRange As Range, msg As String, rng As Range, r As Range
msg = "Click on the top cell of the data"
On Error Resume Next
Do
If rng Is Nothing Then
Set myRange = Application.InputBox(msg, Type:=8)
Set rng = Range(myRange.Cells(1, 1), ActiveSheet.Cells(Rows.Count, myRange.Column).End(xlUp))
Else
Set myRange = Application.InputBox(msg, Type:=8)
Set rng = Union(rng, Range(myRange.Cells(1, 1), _
ActiveSheet.Cells(Rows.Count, myRange.Column).End(xlUp)))
End If
Loop While Err.Number = 0
On Error GoTo 0
If myRange Is Nothing Then Exit Sub
Set dic = CreateObject("scripting.dictionary")
For Each r In rng
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
dic.Add r.Value, 1
Else
dic(r.Value) = dic(r.Value) + 1
End If
End If
Next
Range("k2").Resize(dic.Count) = _
Application.Transpose(dic.keys)
Range("l2").Resize(dic.Count) = _
Application.Transpose(dic.items)
Range("k1", Range("k" & Rows.Count).End(xlUp)).Resize(, 2).Sort _
key1:=Range("l1"), order1:=xlDescending, header:=xlYes
Set dic = Nothing
End Sub

[lucas]

Hi Jindon,
you said dictionary object was your specialty, I see why..nice one

[zest1]

Wow, thank you all for your fabulous help, Tony, Shizam and Jindon.

It's great to have several methods to choose from.

Yes Tony, you're right. The Top10 is perfect, only I would have liked it to be sorted in order, but it's fine as it is.

And yes, Jindon, the lists are consecutive. I changed the one line of code but it takes the separate lists and joins them together in one list, and I wanted to keep the lists separate.

Thanks again! I really appreciate it :)

[jindon]

select the range first, then run the code


Sub test()
Dim dic As Object, a, Dest As Range
Set dic = CreateObject("scripting.dictionary")
a = Selection.Value
On Error Resume Next
Set Dest = Application.InputBox("select cell for result", Type:=8)
If Dest Is Nothing Then Erase a: Exit Sub
On Error GoTo 0
For i = 1 To UBound(a, 2)
For Each e In Application.Index(a, 0, i)
If Not IsEmpty(e) Then
If Not dic.exists(e) Then
dic.Add e, 1
Else
dic(e) = dic(e) + 1
End If
End If
Next
With Dest
.Offset(, n).Resize(dic.Count) = _
Application.Transpose(dic.keys)
.Offset(, n + 1).Resize(dic.Count) = _
Application.Transpose(dic.items)
.Offset(, n).Resize(dic.Count, 2).Sort _
key1:=.Offset(, n + 1), order1:=xlDescending, header:=xlNo
dic.removeall: n = n + 2
End With
Next
Set dic = Nothing: Erase a
End Sub