Recherche d'un ou plusieurs mots d'une liste dans un Document - Trois options

[ouskel'n'or]

Trois options (les deux premières ne nécessitent aucune sélection)

*********************************************************
1 - Le tableau Word et le texte objet de la recherche sont situés dans le même document.
La liste des mots à rechercher est située dans la colonne 1 d'un tableau à deux colonnes placé dans la section 1.
Le texte objet de la recherche est placé dans la section 2

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub ChercherTrouver()
'Désactiver la mise à jour de l'application pour éviter les mouvements de pages
Application.ScreenUpdating = False
Dim Doc1 As Document
Dim TableauDesMots(), i As Integer, NoLigne As Byte
Dim DerLigne As Byte
Set Doc1 = ActiveDocument
    DerLigne = Doc1.Tables(1).Rows.Count
    ReDim Preserve TableauDesMots(DerLigne)
    For NoLigne = 1 To DerLigne
        TableauDesMots(NoLigne) = Doc1.Tables(1).Cell(NoLigne, 1)
        'Suppression de vbcrlf en fin de cellule et ajout du No de ligne
        'formaté sur 4 caractères
        TableauDesMots(NoLigne) = Trim(Left(TableauDesMots(NoLigne), _
        Len(TableauDesMots(NoLigne)) - 2)) & Right("0000" & NoLigne, 4)
    Next
 
    For i = 1 To UBound(TableauDesMots)
        If recherche(Left(TableauDesMots(i), Len(TableauDesMots(i)) - 4), Doc1) Then
            'récup du No de ligne dans le tableau
            NoLigne = Val(Right(TableauDesMots(i), 4))
            'Insertion d'une croix dans la colonne 2 du tableau word
            ActiveDocument.Tables(1).Cell(NoLigne, 2).Range.Text = "X"
        End If
    Next
 
'Réactiver la mise à jour de l'application
Application.ScreenUpdating = True
End Sub
 
Function recherche(LeMot As String, Doc1 As Document) As Boolean
Dim Plage
    Set Plage = Doc1.Sections(2).Range
        With Plage.Find
            .Text = LeMot
            recherche = .Execute
        End With
End Function

**********************************************************
2 - La liste des mots et le texte sont placés dans deux documents différents.
Le document 1 contient la macro, et la liste des mots.
La liste des mots est un tableau Word à deux colonnes dans le premier document.
La colonne 1 contient les mots à rechercher, 1 mot par cellule
La colonne 2 est destinée à recevoir une croix si le mot est trouvé
Le texte à parcourir est dans le second document.

Les documents
"Tableau des mots.doc" contient la macro et le tableau des mots
"C:\Le Rep\Le Texte.doc" contient le texte

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub ChercherTrouver()
Dim Doc1 As Document
Dim Doc2 As Document
Dim TableauDesMots(), ok As Boolean, i As Integer
Dim DerLigne As Byte
'Désactiver la mise à jour de l'application pour éviter les mouvements de pages
Application.ScreenUpdating = False
    Set Doc1 = Documents("Tableau des mots.doc") 'contient la macro
    Set Doc2 = Documents.Open("C:\Le Rep\Le Texte.doc") 'contient le texte
    DoEvents
    DerLigne = Doc1.Tables(1).Rows.Count
    ReDim Preserve TableauDesMots(DerLigne)
    For NoLigne = 1 To DerLigne
        TableauDesMots(NoLigne) = Doc1.Tables(1).Cell(NoLigne, 1)
        'Suppression de vbcrlf en fin de cellule
        'et ajout du No de ligne formaté sur 4 caractères
        TableauDesMots(NoLigne) = Trim(Left(TableauDesMots(NoLigne), _
        Len(TableauDesMots(NoLigne)) - 2)) & Right("0000" & NoLigne, 4)
    Next
 
    For i = 1 To UBound(TableauDesMots)
        ok = recherche(Left(TableauDesMots(i), Len(TableauDesMots(i)) - 4), Doc2)
        If ok Then
            'récup du No de ligne dans le tableau
            NoLigne = Val(Right(TableauDesMots(i), 4))
            'insertion d'une croix dans la colonne adjascente
            Doc1.Tables(1).Cell(NoLigne, 2).Range.Text = "X"
        End If
    Next
 
'Réactiver la mise à jour de l'application
Application.ScreenUpdating = True
End Sub
 
Function recherche(LeMot As String, Doc2 As Document) As Boolean
Dim Plage
    Set Plage = Doc2.Content
        With Plage.Find
            .Text = LeMot
            recherche = .Execute
        End With
End Function

**********************************************************
3 - Les mots cherchés sont situés dans un tableau() dans le code de la macro
Le texte objet de la recherche est situé dans le document contenant la macro

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub ChercherTrouver()
Dim Doc1 As Document
Dim TableauDesMots As Variant, i As Integer
Dim DerLigne As Byte
    Set Doc1 = ActiveDocument
    TableauDesMots = Array("", "tata", "papa", "maman", "pépé", "mémé", "tonton", "michel")
    For i = 1 To UBound(TableauDesMots)
        If recherche(TableauDesMots(i)) Then
            MsgBox TableauDesMots(i) & " trouvé et sélectionné page " & Selection.Information(wdActiveEndPageNumber)
        End If
    Next
End Sub
 
Function recherche(LeMot As Variant) As Boolean
    Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .Text = LeMot
            recherche = .Execute
        End With
End Function

Un grand merci à 3dfroggy qui a été l'initiateur par sa question