Extraire d'un texte ordinaire le nombre de chaque mot différent ?

Sub compteMots()
    Dim wd As Range, dict, k, result(), i As Long, tmp
    Dim doc As Document, tabl As Table
    Set dict = CreateObject("Scripting.Dictionary")
    For Each wd In Selection.Words
        tmp = Split(LCase(wd.Text), "'")
        For i = 0 To UBound(tmp)
            ' compte mots de plus de 3 lettres
            If Len(tmp(i)) > 3 Then If dict.Exists(tmp(i)) Then dict(tmp(i)) = dict(tmp(i)) + 1 Else dict(tmp(i)) = 1
        Next i
    Next wd
    For Each k In dict.keys
        If dict(k) <= 1 Then dict.Remove k    'suppression mots cités 1 seule fois
    Next k
    If dict.Count > 0 Then
        Set doc = Documents.Add
        Set tabl = doc.Tables.Add(Range:=Selection.Range, NumRows:=dict.Count + 1, numcolumns:=2)
        tabl.Cell(1, 1).Range.Text = "Mot": tabl.Cell(1, 2).Range.Text = "Cpt"
        For Each k In dict.keys
            i = i + 1
            tabl.Cell(i, 1).Range.Text = k
            tabl.Cell(i, 2).Range.Text = dict(k)
        Next k
        tabl.Sort True, 2, wdSortFieldNumeric, wdSortOrderDescending
        tabl.Borders.Enable = True
    End If
    Set dict = Nothing
End Sub