VBA Name Ranking

[DarrenF]

I'm trying to Rank the number of times a name show's up in a particular column ("Report Data" Column B) and have it Rank the top ten on another sheet ("Report" starting in cell A16). I haven't been successful finding anything while googling. Does anyone have a good reference video or would like to share what it would look like?

Example:

Data
Jim
Mary
Mike
Paul
Sam
Mary
Jim
Jim
Judy
Mike

Results
1. Jim 3
2. Mary 2
3. Mike 2

 

[lrobbo314]

How about this.

Book1 (version 2).xlsb
	A	B
16	Name	Count
17	Jim	3
18	Mary	2
19	Mike	2
20	Paul	1
21	Sam	1
22	Judy	1
Report

Sub RankIT()
Dim rd As Worksheet:    Set rs = Sheets("Report Data")
Dim rp As Worksheet:    Set rp = Sheets("Report")
Dim r As Range:         Set r = rs.Range("A2:A" & rs.Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(AR)
    SD(AR(i, 1)) = SD(AR(i, 1)) + 1
Next i

Set r = rp.Range("A16:B16")
r.Value = Array("Name", "Count")
Set r = r.Offset(1).Resize(SD.Count, 1)
r.Value = Application.Transpose(SD.keys())
r.Offset(, 1).Value = Application.Transpose(SD.items())
Set r = r.Resize(, 2)
r.Sort Key1:=r.Cells(1, 2), Order1:=xlDescending, Header:=xlNo

End Sub

 

[DarrenF]

Thank you lrobbo314, that worked for the most part. Is there a way to only grab the top 10? Also, leave out any #N/A's? Sorry I know I'm asking for alot.

 

[lrobbo314]

I didn't get any N/As in with the test data you posted. Not sure how to fix that without knowing what's causing it. Can you post a more representative example.

Adding this line of code at the end of the sub will filter for the top 10.

r.AutoFilter Field:=2, Criteria1:="10", Operator:=xlTop10Items

 

[DarrenF]

Yeah, my data that I'm grabbing is actually trying to pull Names, but if that person who entered the data didn't put the first name in the tool it will show up #N/A in my data pull. I'd like to extract those if possible as it will always show up at #1.

 

[lrobbo314]

How about this?

Sub RankIT()
Dim rd As Worksheet:    Set rs = Sheets("Report Data")
Dim rp As Worksheet:    Set rp = Sheets("Report")
Dim r As Range:         Set r = rs.Range("A2:A" & rs.Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")
Dim Top As Integer:     Top = 10
Dim RES() As Variant:   ReDim RES(1 To Top, 1 To 2)

For i = 1 To UBound(AR)
    If Not IsError(AR(i, 1)) Then SD(AR(i, 1)) = SD(AR(i, 1)) + 1
Next i

For j = 0 To SD.Count - 1
    RES(j + 1, 1) = SD.Keys()(j)
    RES(j + 1, 2) = SD.Items()(j)
    Top = Top - 1
    If Top = 0 Then Exit For
Next j

Set r = rp.Range("A16:B16")
r.Value = Array("Name", "Count")
r.Offset(1).Resize(UBound(RES), 2).Value2 = RES

End Sub