Recherche de mots entourés de deux '*'

**tetetete** · 10/07/2019, 12h01

Bonjour,
je cherche actuellement à faire une macro qui recherche tout les mots du type *FDSDFSFHSDHQ* pour pouvoir modifier leur police. Le point commun des ces mots est qu'ils commencent et finissent tous par *.
Je sais déjà comment modifier la police et tout le reste, juste je ne sais pas comment trouver tout les mots avec cette forme.
Cordialement,
tetetete

Invité · 10/07/2019, 18h22

Envoyé par tetetete

Bonjour,

A tester :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 
Option Explicit
 
Sub RechercheEntreEtoiles()
 
Dim I As Long, IndexMatrice As Long
Dim DocEnCours As Document
Dim MatriceEtoiles() As Variant
Dim MonRange As Range
Dim PositionCaractere As Integer
 
   On Error GoTo Fin
 
   Set DocEnCours = ActiveDocument
 
   With DocEnCours
 
        .Range.HighlightColorIndex = wdAuto
 
        IndexMatrice = 0
        PositionCaractere = 0
        For I = 1 To .Characters.Count
            If .Characters(I).Text = "*" Then
                If PositionCaractere = 0 Then
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                   PositionCaractere = 1
                Else
                   MatriceEtoiles(1, IndexMatrice) = I
                   IndexMatrice = IndexMatrice + 1
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                End If
            End If
        Next I
 
        For IndexMatrice = LBound(MatriceEtoiles, 2) To UBound(MatriceEtoiles, 2)
            Set MonRange = Selection.Range
            MonRange.SetRange MatriceEtoiles(0, IndexMatrice), MatriceEtoiles(1, IndexMatrice)
            With MonRange
              If .Words.Count = 3 Then
                  MatriceEtoiles(2, IndexMatrice) = MonRange.Text
                  With MonRange
                       .HighlightColorIndex = wdYellow
                       ' Suite de la mise en forme....
 
                  End With
               End If
           End With
           Set MonRange = Nothing
        Next IndexMatrice
 
   End With
 
   GoTo Fin
 
Fin:
 
   Set MonRange = Nothing
   Set DocEnCours = Nothing
 
End Sub

**tetetete** · 11/07/2019, 08h09

Bonjour,
Tout d'abord merci de ton aide.
Cependant, j'ai un problème, lorsque je lance la macro, word ne répond plus. Je pense que la cause est le fait qu'il y ait environ 10 000 mots dans mon documents et que la macro les parcourt tous.
Si tu as une solution,
Cordialement,
tetetete

Invité · 11/07/2019, 08h15

Envoyé par tetetete

Encadrez le code avec des Application.ScreenUpdating mais pas sur que cela change grand chose.

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
 
Sub RechercheEntreEtoiles()
 
Dim I As Long, IndexMatrice As Long
Dim DocEnCours As Document
Dim MatriceEtoiles() As Variant
Dim MonRange As Range
Dim PositionCaractere As Integer
 
   On Error GoTo Fin
 
   Application.ScreenUpdating = False
   Set DocEnCours = ActiveDocument
 
   With DocEnCours
 
        .Range.HighlightColorIndex = wdAuto
 
        IndexMatrice = 0
        PositionCaractere = 0
        For I = 1 To .Characters.Count
            If .Characters(I).Text = "*" Then
                If PositionCaractere = 0 Then
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                   PositionCaractere = 1
                Else
                   MatriceEtoiles(1, IndexMatrice) = I
                   IndexMatrice = IndexMatrice + 1
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                End If
            End If
        Next I
 
        For IndexMatrice = LBound(MatriceEtoiles, 2) To UBound(MatriceEtoiles, 2)
            Set MonRange = Selection.Range
            MonRange.SetRange MatriceEtoiles(0, IndexMatrice), MatriceEtoiles(1, IndexMatrice)
            With MonRange
              If .Words.Count = 3 Then
                  MatriceEtoiles(2, IndexMatrice) = MonRange.Text
                  With MonRange
                       .HighlightColorIndex = wdYellow
                       ' Suite de la mise en forme....
 
                  End With
               End If
           End With
           Set MonRange = Nothing
        Next IndexMatrice
 
   End With
 
 
   GoTo Fin
 
Fin:
 
   Application.ScreenUpdating = True
 
   Set MonRange = Nothing
   Set DocEnCours = Nothing
 
End Sub

**tetetete** · 11/07/2019, 09h12

Je l'avais déjà fait et cela ne change rien.

**tetetete** · 11/07/2019, 09h30

Je viens de tester sur un page, cela prend un peu de temps mais la macro s'execute.
Il y a juste un problème sur la deuxième partie du code.

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
For IndexMatrice = LBound(MatriceEtoiles, 2) To UBound(MatriceEtoiles, 2)
            Set MonRange = Selection.Range
            MonRange.SetRange MatriceEtoiles(0, IndexMatrice), MatriceEtoiles(1, IndexMatrice)
            With MonRange
              If .Words.Count = 3 Then
                  MatriceEtoiles(2, IndexMatrice) = MonRange.Text
                  MsgBox "test"
                  With MonRange
                       '.HighlightColorIndex = wdYellow
                       ' Suite de la mise en forme....
                       '.Font.Name = "Code 3 de 9"
                  End With
               End If
           End With
           Set MonRange = Nothing
        Next IndexMatrice

Sur cette ligne : If .Words.Count = 3 Then la condition n'est surement pas validé et donc je ne peux pas changer la mise en forme

Invité · 11/07/2019, 09h35

Envoyé par tetetete

Et si vous expliquiez dans quel contexte vous utilisez ce code ? Comment arrivent ces ""*" dans votre document ?

**tetetete** · 11/07/2019, 09h41

Je vous est joint mon fichier.
En fait le but est de transformer les mots *SDFSDFSDF* en code barre.
Je vous ai mis en exemple une page, il y en a une 20ène similaire.

Invité · 11/07/2019, 09h49

Envoyé par tetetete

Créez une boucle sur la collection Paragraphs du document et testez avec la fonction Instr la présence du caractère * en début de chaîne dans le Range du paragraphe en cours.

**tetetete** · 11/07/2019, 09h54

Je ne suis pas sur de très bien comprendre. Pouvez-vous m'expliquer comment faire

Invité · 11/07/2019, 10h02

Envoyé par tetetete

Je ne suis pas sur de très bien comprendre. Pouvez-vous m'expliquer comment faire

Pour la boucle, vous avez déjà le modèle dans la macro que je vous ai fournie, il faut juste remplacer la collection Characters par la collection Paragraphs. En suite, il faut tester du paragraphe en cours dans la boucle. Quant à la fonction INSTR, la première chose à faire est d'aller voir son utilisation dans l'aide en ligne VBA Word ou de requéter le forum VBA Word pour récupérer des exemples. Cette fonction permet de vérifier la position d'un caractère ou d'une chaîne à l'intérieur d'une autre chaîne (ici .Paragraphs(I).Range.Text)., si le résultat = 1 cela signifie que la chaîne commence par *.

**tetetete** · 11/07/2019, 11h17

J'ai fait ceci

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Sub RechercheEntreEtoiles()
 
Application.ScreenUpdating = False
 
 
Dim I As Long, IndexMatrice As Long
Dim DocEnCours As Document
Dim MatriceEtoiles() As Variant
Dim MonRange As Range
Dim PositionCaractere As Integer
 
   On Error GoTo Fin
 
   Set DocEnCours = ActiveDocument
  'LENTEUR EXTREME
   With DocEnCours
 
        .Range.HighlightColorIndex = wdAuto
 
        IndexMatrice = 0
        PositionCaractere = 0
 
        For I = 1 To .Paragraphs.Count
        If InStr(.Paragraphs(I).Range.Text, "*") = 1 Then
                If PositionCaractere = 0 Then
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                   PositionCaractere = 1
                Else
                   MatriceEtoiles(1, IndexMatrice) = I
                   IndexMatrice = IndexMatrice + 1
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                End If
            End If
        Next I
 
        'OK
        For IndexMatrice = LBound(MatriceEtoiles, 2) To UBound(MatriceEtoiles, 2)
            Set MonRange = Selection.Range
            MonRange.SetRange MatriceEtoiles(0, IndexMatrice), MatriceEtoiles(1, IndexMatrice)
            With MonRange
              If .Words.Count = 3 Then
                  MatriceEtoiles(2, IndexMatrice) = MonRange.Text
                  With MonRange
                       '.HighlightColorIndex = wdYellow
                       ' Suite de la mise en forme....
                       .Font.Name = "Code 3 de 9"
                  End With
               End If
           End With
           Set MonRange = Nothing
        Next IndexMatrice
 
   End With
 
   GoTo Fin
 
Fin:
 
   Set MonRange = Nothing
   Set DocEnCours = Nothing
 
    Application.ScreenUpdating = True
 
 
 
End Sub

Le code est instantané, il me semble que cela marche sauf le problème que j'avais auparavant au niveau de la ligne : If .Words.Count = 3 Then

Invité · 11/07/2019, 11h47

Envoyé par tetetete

Le code initial correspond au cas où plusieurs chaînes coexistent dans une même ligne. Si vous analysez votre fichier, il n'y pas d'autres cas où une chaîne de caractères dans un paragraphe commence par *. Donc, si la condition avec Instr = 1, la chaine du paragraphe correspond à ce que vous cherchez, il n'est pas utile de tester le nombre de mots de la chaîne.

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
 
Sub RechercheEntreEtoilesV2()
 
Dim I As Long
Dim DocEnCours As Document
 
   On Error GoTo Fin
 
   Application.ScreenUpdating = False
 
   Set DocEnCours = ActiveDocument
   With DocEnCours
 
        .Range.HighlightColorIndex = wdAuto
 
 
        For I = 1 To .Paragraphs.Count
            If InStr(1,.Paragraphs(I).Range.Text, "*") = 1 Then
                With .Paragraphs(I).Range
                   '  .HighlightColorIndex = wdYellow
                     .Font.Name = "Code 3 de 9"
                End With
            End If
        Next I
 
   End With
 
   GoTo Fin
 
Fin:
 
    Set DocEnCours = Nothing
 
    Application.ScreenUpdating = True
 
End Sub

**tetetete** · 11/07/2019, 12h12

Cela marche bien pour l'exemple que je t'ai donné mais cela marche moins bien pour d'autres. Je te joint un nouveau fichier *CAROUS....* ne devient un code barre et d'autres sont buggés, globalement tout ceux à droite.

Invité · 11/07/2019, 13h01

Envoyé par tetetete

Il faut combiner les deux codes. Avec Instr, tester le range de chaque paragraphe. Si une * est trouvée, décompter les nombre d'étoiles dans le range sachant que le nombre d'étoiles est forcément pair. Il faut donc analyser caractère par caractère le range du paragraphe en cours (seulement ceux contenant au moins une étoile) et mémoriser dans la matrice les positions paires et impaires des caractères *.

Ensuite, mettre en forme avec le même code qu'initialement. Dans le code initial, on testait le nombre de mots dans la chaîne (3 : 2 pour les *, 1 pour le mot). Dans ce dernier document, les points correspondent à des mots. Mais avec le principe que les étoiles apparaissent par paires, ce test n'est plus nécessaire.

**tetetete** · 11/07/2019, 15h27

J'ai essayé de modifier comme vous me l'avez dit mais ça ne marche pas.

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Sub RechercheEntreEtoiles()
 
Dim I As Long, IndexMatrice As Long
Dim DocEnCours As Document
Dim MatriceEtoiles() As Variant
Dim MonRange As Range
Dim PositionCaractere As Integer
 
   On Error GoTo Fin
 
   Application.ScreenUpdating = False
 
   Set DocEnCours = ActiveDocument
   With DocEnCours
 
        .Range.HighlightColorIndex = wdAuto
 
        For I = 1 To .Paragraphs.Count
            If InStr(1, .Paragraphs(I).Range.Text, "*") = 1 Then
                If PositionCaractere = 0 Then
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                   PositionCaractere = 1
                Else
                   MatriceEtoiles(1, IndexMatrice) = I
                   IndexMatrice = IndexMatrice + 1
                   ReDim Preserve MatriceEtoiles(2, IndexMatrice)
                   MatriceEtoiles(0, IndexMatrice) = I - 1
                End If
            End If
        Next I
 
 
        For IndexMatrice = LBound(MatriceEtoiles, 2) To UBound(MatriceEtoiles, 2)
            Set MonRange = Selection.Range
            MonRange.SetRange MatriceEtoiles(0, IndexMatrice), MatriceEtoiles(1, IndexMatrice)
            With MonRange
              If .Words.Count = 3 Then
                  MatriceEtoiles(2, IndexMatrice) = MonRange.Text
                  With MonRange
                       '.HighlightColorIndex = wdYellow
                       ' Suite de la mise en forme....
                       .Font.Name = "Code 3 de 9"
 
                  End With
               End If
           End With
           Set MonRange = Nothing
        Next IndexMatrice
 
   End With
 
   GoTo Fin
 
Fin:
 
    Set DocEnCours = Nothing
 
    Application.ScreenUpdating = True
 
End Sub

Invité · 11/07/2019, 16h24

Envoyé par tetetete

On voit dans ce vidage d'écran que le document est composé de sauts de colonnes qui visiblement ne permettent pas d'identifier la position des * depuis le début de document.
Ce document doit-il rester dans sa forme initiale ?
Pièce jointe 490504

**tetetete** · 12/07/2019, 09h07

Le mieux serait qu'il reste dans sa forme originale mais il peut être changé tant que de la ligne push jusqu'a la ligne avec cette forme *DFGDFGSDDF* sont groupés

Invité · 12/07/2019, 13h12

Envoyé par tetetete

Testez cette solution bâtie à partir de signets :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
 
Public DocEnCours As Document
 
Sub RechercheEntreEtoilesV3()
 
 
Dim I As Long, CaractereEnCours As Long
Dim MonRange As Range
Dim IndexSignet As Integer
 
   On Error GoTo Fin
 
  ' Application.ScreenUpdating = False
 
   Set DocEnCours = Documents("exemple (2).docx") 'ActiveDocument
  ' Set DocEnCours = ActiveDocument
 
   With DocEnCours
 
        For I = .Bookmarks.Count To 1 Step -1
            .Bookmarks(I).Delete
        Next I
        IndexSignet = 1
 
        .Range.HighlightColorIndex = wdAuto
 
        For I = 1 To .Paragraphs.Count
            .Paragraphs(I).Range.Select
            If InStr(1, .Paragraphs(I).Range.Text, "*", vbTextCompare) > 0 Then
              .Paragraphs(I).Range.Select
              With Selection
                   If IndexSignet < 10 Then
                      .Bookmarks.Add Name:="Signet0" & IndexSignet
                   Else
                      .Bookmarks.Add Name:="Signet" & IndexSignet
                   End If
                   IndexSignet = IndexSignet + 1
              End With
            End If
        Next I
 
        If IndexSignet > 0 Then
           For I = 1 To .Bookmarks.Count
               EssaiSignet DocEnCours, .Bookmarks(I)
           Next I
        End If
 
   End With
 
   GoTo Fin
 
Fin:
 
   Set MonRange = Nothing
   Set DocEnCours = Nothing
 
  '  Application.ScreenUpdating = True
 
End Sub
 
 
 
Sub EssaiSignet(ByVal DocEnCours2 As Document, ByVal MonSignet2 As Bookmark)
 
Dim MonRange1 As Range, MonRange2 As Range
Dim J As Long, Pos1 As Long, Pos2 As Long
Dim MesCaracteres As String
Dim MesPositions As Variant
 
   With DocEnCours2
 
        With MonSignet2
             Pos1 = .Range.Start
             Pos2 = .Range.End
        End With
 
        Set MonRange1 = .Range(Start:=Pos1, End:=Pos2)
 
        MesCaracteres = ""
        For J = 1 To Len(MonRange1.Text)
            If Mid(MonRange1.Text, J, 1) = "*" Then
               MesCaracteres = MesCaracteres & J & "-"
            End If
        Next J
 
        If Len(MesCaracteres) > 0 Then
 
           MesCaracteres = Mid(MesCaracteres, 1, Len(MesCaracteres) - 1)
           MesPositions = Split(MesCaracteres, "-")
           For J = LBound(MesPositions) To UBound(MesPositions)
 
             Select Case J
                    Case 0
                       If Pos1 + MesPositions(J) - 1 = Pos1 Then
                         Set MonRange2 = .Range(Start:=Pos1 + MesPositions(J) - 1, End:=Pos1 + MesPositions(J + 1))
                         With MonRange2
                              .HighlightColorIndex = wdYellow
                         End With
                          Debug.Print MonRange2 & ", pos1 " & Pos1 & " : " & Pos1 + MesPositions(J) - 1 & ", pos2 " & Pos2 + MesPositions(J + 1)
 
                         Set MonRange2 = Nothing
                       Else
                         Set MonRange2 = .Range(Start:=Pos1 + MesPositions(J), End:=Pos1 + MesPositions(J + 1) + 1)
                         With MonRange2
                              .HighlightColorIndex = wdYellow
                         End With
                          Debug.Print MonRange2 & ", pos1 " & Pos1 & " : " & Pos1 + MesPositions(J) & ", pos2 " & Pos2 + MesPositions(J + 1) + 1
 
                         Set MonRange2 = Nothing
 
 
                       End If
 
                    Case 2, 4
                         Set MonRange2 = .Range(Start:=Pos1 + MesPositions(J) - 1, End:=Pos1 + MesPositions(J + 1))
                         With MonRange2
                              .HighlightColorIndex = wdYellow
                         End With
                          Debug.Print MonRange2 & ", pos1 " & Pos1 & " : " & Pos1 + MesPositions(J) - 1 & ", pos2 " & Pos2 + MesPositions(J + 1)
 
                         Set MonRange2 = Nothing
             End Select
            Next J
 
        End If
 
        Set MonRange1 = Nothing
 
  End With
 
End Sub

**tetetete** · 15/07/2019, 09h31

Merci beaucoup, cela marche !!
J'aurais juste 2 petites autres questions

, j'aimerai savoir si cela est possible avec de me lancer dans des choses impossibles.

Est-ce possible de vérifier si un texte avec une police spéciale est en fin de page si non faire des sauts de lignes sur la page pour qu'il soit en fin de page ?
Ajouter du texte à une entête ? (j'aimerai agrandir mon entête en y ajoutant les noms des colonnes ?

Cordialement,
tetetete

Recherche de mots entourés de deux '*'

VBA Word

Discussions similaires

Partager

Partager