I got an error. Would this be the same kind of output you were going for?
Sub WordCount2() Dim Rng As Range, Dn As Range Dim oMax As Double Dim K As Variant Dim Msg As String Dim vWords As Variant Dim myWord As Variant Dim counter As Integer, WordCount As Integer Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)) With CreateObject("scripting.dictionary") .CompareMode = vbTextCompare For Each Dn In Rng vWords = Split(Dn.Text, " ") For Each myWord In vWords If Not .Exists(myWord) Then .Add myWord, 1 WordCount = WordCount + 1 Else .Item(myWord) = .Item(myWord) + 1 End If Next Next counter = 2 Do For Each K In .keys oMax = Application.Large(Application.Transpose(.Items), counter) If .Item(K) = oMax Then If Application.CountIf(Range("B1:B" & counter), K) = 0 Then Cells(counter, 2) = K Cells(counter, 3) = .Item(K) counter = counter + 1 End If End If

 Next K
Loop Until counter = WordCount
 End With
 End Sub

    Sub WordCount()
    Dim Rng As Range, Dn As Range
    Dim oMax As Double
    Dim K As Variant
    Dim Msg As String
    Dim vWords As Variant
    Dim myWord As Variant
    Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
            For Each Dn In Rng
            vWords = Split(Dn.Text, " ")
                For Each myWord In vWords
                    If Not .Exists(myWord) Then
                    .Add myWord, 1
                Else
                    .Item(myWord) = .Item(myWord) + 1
                End If
                Next
            Next
    oMax = Application.Max(Application.Transpose(.Items))
    MyRow = 1
    For Each K In .keys
        If .Item(K) = oMax Then
            Msg = Msg & K & ","
        End If
        Cells(MyRow, 2).Value = .Item(K)
        Cells(MyRow, 3).Value = K
        MyRow = MyRow + 1
    Next K
    MsgBox "The Number/s :- " & Msg & " Appeared " & oMax & " Times"
    End With
    End Sub