Générer une liste de mots avec leur occurrence (plusieurs cellules)

Option Explicit

Sub Vazy()
Dim Plage As Range, C As Range, arr, Dict As Object, strTexteComplet As String, temp As String
    Set Plage = Sheets("Feuil1").Range("A1:H23")  'A ADAPTER LA PLAGE CONTENANT LES DONNEES
    For Each C In Plage.Cells
        strTexteComplet = strTexteComplet & C.Text
    Next
    temp = RemovePunctuation(strTexteComplet)
    temp = UCase$(temp)
    arr = Split(temp, " ")
    Set Dict = CreateObject("Scripting.Dictionary")
    FillDictionary Dict, arr
    Erase arr
    SortDictByFreq Dict, arr
    DisplayTheTopMostUsedWords arr, 10
    Debug.Print "Mots différents dans la plage : " & Dict.Count
    Debug.Print "-------------------------"
    Debug.Print ""
    Debug.Print "Optionally : "
    Debug.Print "Fréquence du mot : ""contenu"" : " & DisplayFrequencyOf(UCase("contenu"), Dict)
    Debug.Print "Fréquence du mot : ""représente"" : " & DisplayFrequencyOf(UCase("représente"), Dict)
    Debug.Print "Fréquence du mot : ""tititototata"" : " & DisplayFrequencyOf(UCase("tititototata"), Dict)
    Debug.Print "-------------------------"
End Sub
Public Function RemovePunctuation(strBook As String) As String
Dim T, i As Integer, temp As String
Const PUNCT As String = """,;:!?."

   T = Split(StrConv(PUNCT, vbUnicode), Chr(0))
   temp = strBook
   For i = LBound(T) To UBound(T) - 1
      temp = Replace(temp, T(i), " ")
   Next
   temp = Replace(temp, "--", " ")
   temp = Replace(temp, "...", " ")
   temp = Replace(temp, vbCrLf, " ")
   RemovePunctuation = Replace(temp, "  ", " ")
End Function
Public Sub FillDictionary(D As Object, a As Variant)
Dim l As Long

   For l = LBound(a) To UBound(a)
      If a(l) <> "" Then D(a(l)) = D(a(l)) + 1
   Next
End Sub
Public Sub SortDictByFreq(D As Object, MyArr As Variant)
Dim k
Dim l As Long
   ReDim MyArr(1 To D.Count, 1 To 2)
   For Each k In D.Keys
      l = l + 1
      MyArr(l, 1) = k
      MyArr(l, 2) = CLng(D(k))
   Next
   SortArray MyArr, LBound(MyArr), UBound(MyArr), 2
End Sub
Public Sub SortArray(a, le As Long, Ri As Long, Col As Long)
Dim ref As Long, l As Long, r As Long, temp As Variant
   ref = a((le + Ri) \ 2, Col)
   l = le
   r = Ri
   Do
         Do While a(l, Col) < ref
            l = l + 1
         Loop
         Do While ref < a(r, Col)
            r = r - 1
         Loop
         If l <= r Then
            temp = a(l, 1)
            a(l, 1) = a(r, 1)
            a(r, 1) = temp
            temp = a(l, 2)
            a(l, 2) = a(r, 2)
            a(r, 2) = temp
            l = l + 1
            r = r - 1
         End If
   Loop While l <= r
   If l < Ri Then SortArray a, l, Ri, Col
   If le < r Then SortArray a, le, r, Col
End Sub
Public Sub DisplayTheTopMostUsedWords(arr As Variant, Nb As Long)
Dim l As Long, i As Integer
   i = 1
   Debug.Print "Rang Mot    Frequence"
   Debug.Print "==== ======= ========="
   For l = UBound(arr) To UBound(arr) - Nb + 1 Step -1
      Debug.Print Left$(CStr(i) & "    ", 5) & Left$(arr(l, 1) & "       ", 8) & " " & arr(l, 2)
      i = i + 1
   Next
End Sub
Public Function DisplayFrequencyOf(Word As String, D As Object) As Long
   If D.Exists(Word) Then DisplayFrequencyOf = D(Word)
End Function