Sub WordsRating()
    Dim data As Range, i&, temp, cell, dic As Object, res As Worksheet
    Dim dKeys, dItems
    If Not Intersect(ActiveSheet.UsedRange, Selection) Is Nothing Then
        If Selection.Count > 1 Then
            Set data = Intersect(ActiveSheet.UsedRange, Selection)
        Else
            Set data = Selection
        End If
        Set dic = CreateObject("scripting.dictionary")
        For Each cell In data
            temp = Split(cell, " ")
            If UBound(temp) >= 0 Then
                For i = 0 To UBound(temp)
                    If Trim(temp(i)) <> "" Then dic(Trim(temp(i))) = dic(Trim(temp(i))) + 1
                Next i
            End If
        Next cell
        Set res = ActiveWorkbook.Sheets.Add
        With res
            dKeys = dic.keys
            dItems = dic.items
            For i = 0 To UBound(dKeys)
                .Cells(i + 1, 1).Value = dKeys(i)
                .Cells(i + 1, 2) = dItems(i)
            Next i
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("b1:b" & i) _
                , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range("A1:B" & i)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            If UBound(dKeys) >= 300 Then .Range("a301:b" & i).ClearContents
        End With
    End If
End Sub

If UBound(temp) > 0 Then

If UBound(temp) >= 0 Then