Extraer la cadena de texto que mas se repiten en excel

Te mando mi solución con un ejemplo. Sigue mis pasos:

Tenemos la columna A con descripciones en sus celdas desde A1 hacia abajo.

Necesitamos tener libres (para este ejemplo) las columnas B y C, no no estuvieran libres solo tienes que insertar dos columnas a continuación de la A

Ahora solo tienes que ejecutar esta macro y listo!

Sub palabras()
'por Luismondelo
Do While ActiveCell.Value <> ""
tope = Len(ActiveCell)
For x = 1 To tope + 1
extrae = Mid(ActiveCell, x, 1)
If extrae = "" Then
Final = Final & "," & lista
lista = ""
End If
If extrae = " " Then
Final = Final & "," & lista
lista = ""
End If
lista = lista & extrae
Next
ActiveCell.Offset(1, 0).Select
Loop
Final = Replace(Final, " ", "")
Final = Mid(Final, 2, Len(Final) - 1)
Final = Split(Final, ",")
Range("b1").Select
For p = 0 To UBound(Final)
ActiveCell.Value = Final(p)
ActiveCell.Offset(1, 0).Select
Next
Range("b1").Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.CountIf(Columns(2), ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ultima = ActiveCell.Row
Range("b1:c" & Range("c65000").End(xlUp).Row).Sort key1:=Range("c1"), order1:=xlDescending, Header:=xlNo, ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
palabra = Range("b1").Value
cantidad = Range("c1").Value
Columns("b:c").EntireColumn.Delete
MsgBox "La palabra más repetida ha sido: " & palabra & " con " & cantidad & " veces"
End Sub

recuerda finalizar y puntuar

Buen Dia Luis tengo un problema en la siguiente linea Final = Mid(Final, 2, Len(Final) - 1) me tira error 5 en tiempo de ejecucion

La macro la acabo de probar y funciona perfectamente. Solo me queda que me digas un mail para mandártelo.

Un saluddo