Find the top five names and occurrence

Sub GetTopFive()
' hiker95, 01/03/2015, ME826885
Dim c As Range, lc As Long, r As Long, lr As Long, t As String
Application.ScreenUpdating = False
lc = Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In Range("A2:A25")
    If Not .Exists(c.Value) Then
      .Add c.Value, 1
    Else
      .Item(c.Value) = .Item(c.Value) + 1
    End If
  Next c
  Cells(1, lc + 2).Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
End With
lr = Cells(Rows.Count, lc + 2).End(xlUp).Row
Range(Cells(1, lc + 2), Cells(lr, lc + 3)).Sort key1:=Cells(1, lc + 3), order1:=2, key2:=Cells(1, lc + 2), order1:=1
If lr > 5 Then
  For r = 1 To 5
    t = t & Cells(r, lc + 2) & " " & Cells(r, lc + 3) & vbLf
  Next r
Else
  For r = 1 To lr
    t = t & Cells(r, lc + 2) & " " & Cells(r, lc + 3) & vbLf
  Next r
End If
Range(Cells(1, lc + 2), Cells(lr, lc + 3)).ClearContents
Application.ScreenUpdating = True
MsgBox (t)
End Sub

Sub ReadNamesAndNumbers()
Dim Iprng As Range, cel As Range
Dim temp As String, disp As String


Set Iprng = Range(InputBox("Enter the range (Eg A1:A23):"))


For Each cel In Iprng


    If InStr(1, temp, cel.Value) = 0 Then
    disp = disp & Chr(10) & cel.Value & WorksheetFunction.Rept(" ", 20 - Len(cel.Value)) & WorksheetFunction.CountIf(Iprng, cel.Value)
    temp = temp & cel.Value
    End If


Next cel


If temp <> "" Then MsgBox (disp)


End Sub

Sub ReadNamesAndNumbers()
Dim Iprng As Range, cel As Range
Dim temp As String, disp As String, tempdisp  As String
Dim Namecount(1 To 5) As Long


Set Iprng = Range(InputBox("Enter the range (Eg A1:A23):"))


For T = 1 To 5


For Each cel In Iprng


    If InStr(1, temp, cel.Value) = 0 Then
        If Namecount(T) < WorksheetFunction.CountIf(Iprng, cel.Value) Then
        Namecount(T) = WorksheetFunction.CountIf(Iprng, cel.Value)
        tempdisp = cel.Value & WorksheetFunction.Rept(" ", 20 - Len(cel.Value)) & Namecount(T)
        tempcelval = cel.Value
        End If
    End If


Next cel
temp = tempcelval & temp
tempcelval = ""
disp = disp & Chr(10) & tempdisp


Next T


If temp <> "" Then MsgBox (disp)


End Sub