Rank and Count Formula

[bbalch]

I'm trying to create a formula that will rank and count responses to survey data that will summarize the top 5 in the format below. The data will be structured similar to the table below with new responses being added to the bottom of the table continually. For this example, the data is in B2:B12.


Any suggestions on a formula that will count and rank the data as new responses are added? I'm also trying to show the results as Item (#)...for example Apple (4), Orange (3), etc. as they are ranked. See the bottom of the table below.

In the event of tie, (Pear and Plum) below they would both need to be shown.

Thanks in advance for any help / suggestions.


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Favorite Food
[/TD]
[/TR]
[TR]
[TD]Row 2[/TD]
[TD]Apple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Apple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Apple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Apple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Orange[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Orange
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Orange[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Strawberry[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Strawberry[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Pear[/TD]
[/TR]
[TR]
[TD]Row 12[/TD]
[TD]Plum[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Rank[/TD]
[TD]Count[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Apple (4)[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Orange (3)[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Strawberry (2)[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Pear (1)[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]Plum (1)[/TD]
[/TR]
</tbody>[/TABLE]

 

[Special-K99]

Pivot table might be the answer rather than formulas.
Or Power Query, though I don't know anything about that.

 

[anthonyexcel]

This is definitely not the best code but it will do. This assumes that your data is in Column A. It will output using Columns J, K, and L .
You will need to reference Microsoft Scripting Runtime
Tools
References
Microfost Scripting Runtime

Sub MoveItOver()
Application.ScreenUpdating = False
Dim dic As New Dictionary
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Range
Set r = Range("A2:A" & lastrow)
    For Each xcell In r
        If Not dic.Exists(xcell.Value) Then
            dic.Add xcell.Value, 1
        Else
            dic.Item(xcell.Value) = dic.Item(xcell.Value) + 1
        End If
    Next
    Dim i As Long
    Dim k
    i = 1
        For Each k In dic.Keys
        i = i + 1
            Cells(i, 10).Value = i - 1
            Cells(i, 11).Value = k & " (" & dic(k) & ")"
        Next
        Range("J1").Value = "Rank"
        Range("K1").Value = "Count"
    Set dic = Nothing
    Parseit
    Sortit
Application.ScreenUpdating = True
End Sub


Private Sub Parseit()
Dim lastrow As Long '
lastrow = Cells(Rows.Count, "K").End(xlUp).Row
Dim r As Range
Set r = Range("K2:K" & lastrow)
Dim parts() As String
    For Each xcell In r
        parts = Split(xcell.Value, "(")
        xcell.Offset(0, 1).Value = Replace(parts(1), ")", "")
    Next
End Sub


Private Sub Sortit()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("L1:L" & lastrow) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("K2:L" & lastrow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("L2:L" & lastrow).Clear
End Sub