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 : Sélectionner tout - Visualiser dans une fenêtre à part
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 : Sélectionner tout - Visualiser dans une fenêtre à part
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
Un grand merci à 3dfroggy qui a été l'initiateur par sa question
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Partager