VBA Word - Erreur programme

Bonjour,

Dans le cadre d'un projet au sein de mon entreprise je voudrais créer un programme VBA qui , à partir d'un fichier word purement textuel, détecte et surligne tous les mots clés préalablement définis simultanément. Par la suite, ce même programme créera un fichier word avec un tableau exprimant la recurrence de ces mots clés.

J'ai élaboré ce programme, il est fonctionnel mais le seul problème et que dans le 2ème partie du programme il affiche tous les mots alors que je ne souhaite qu'il affiche seulement les mots-clés préalablement surlignés (1ère partie du programme).

Code:

Sub compteMots()

Dim Trouver

Dim MonRang As Range

Dim y As Long

Dim wd As Range, dict, k, result(), i As Long, tmp

Dim doc As Document, tabl As Table

Set dict = CreateObject("Scripting.Dictionary")

Trouver = Array("accesoires haute pression", "accessoires HP", "assistance", "buse", "buse rotative", "cat pumps", "concepteur", "conception", "conseil", "désalinisation", "entretien", "epreuve hp", "groupe motopompe", "haute pression", "hp", "Hughes", "hughes pumps", "hydrocurage", "hydrodémolition", "ingénierie hydraulique", "lance", "lubrification de machines-outils", "machine spéciale", "maintenance", "nettoyage", "nettoyage industriel", "nettoyeur", "osmose", "pistolet", "poignée", "pompe", "pratissoli", "préparation de surface", "raccords rapides", "réalisation sur-mesure", "remise en état", "rotabuse", "support technique", "surpresseur", "télescope", "tête auto-rotative", "tête de lavage", "tête de nettoyage", "très haute pression", "THP", "ultra haute pression", "UHP", "vanne HP")

For y = 0 To UBound(Trouver)

Set MonRang = ActiveDocument.Range

MonRang.Find.Text = Trouver(y)

Do Until MonRang.Find.Execute = False

MonRang.HighlightColorIndex = wdBrightGreen

Loop

Next

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 HighlightColorIndex = wdBrightGreen Then dict.Remove k 'suppression mots pas surlignés

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

Je remercie ardemment et très vivement toute aide car en ce moment je suis au bout de laisser tomber le projet. N'hésitez pas à me contacter si je n'es pas été assez claire sur quoique ce soit. Encore une fois, merci