Sélectionner pour appliquer gras à un ensemble de chaînes de caractères commençant finissant par un caractère

**Vincentfoug** · 10/08/2020, 14h03

Bonjour à tous !

Je cherche à sélectionner des ensembles de chaîne de caractères (phrases dont espaces) commençant par "{" et terminant par "}" pour pouvoir les mettre automatiquement en gras.

Par exemple dans : • Fleurs {bleuâtres}, 0,7-0,8 cm, par 1-4 sur un pédoncule presque toujours à {arrête au sommet}, {> feuille}.

et ce dans un document entier. J'ai utilisé ces caractères justement pour pouvoir repérer ces bouts de phrases et pouvoir les sélectionner pour les mettre tous en gras d'un coup, mais je bloque...

Merci de votre retour

!!!!

**Jean-Philippe André** · 14/08/2020, 16h58

Salut,

tu peux découper ton idée en plusieurs étapes :
- trouver le caractère {
- continuer de parcourir les caractères jusqu'à trouver ton caractère }
- mettre en gras l'entre deux et supprimer les caractères {}

Pour trouver le code VBA qui correspond, tu peux commencer par utiliser l'enregistreur de macros pour les étapes 1 et 3.

Pour l'étape 2, ca restera une boucle itérative.

Il faut s'assurer dans tous les cas que toute accolade { est bien couplée à une accolade }.

**Vincentfoug** · 14/08/2020, 22h10

Merci beaucoup Jean-Philippe, c'est exactement ça !
Par contre je ne sais pas coder et je n'y connais rien

Sauriez-vous me donner les indications ?

Merci beaucoup !!!

**Vincentfoug** · 18/08/2020, 07h47

Bonjour, je me permets une petite relance.

Merci !!

**Jean-Philippe André** · 18/08/2020, 18h24

Sur quelle partie du processus bloques tu vraiment ?

Lancer l'enregistreur de macro ?
Faire un Ctrl+F ?
Mettre en gras ?

Quel est le code qui est généré ? Comment peux tu l'adapter ?

**Vincentfoug** · 18/08/2020, 23h27

Bonsoir Jean-Philippe,

Je suis désolé, j'exécute les manipulations et n'est enregistré que le bout de code ci-dessous qui est totalement tronqué/incomplet

:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub gras()
'
' gras Macro
'
'
    Selection.Font.Bold = wdToggle
    Selection.TypeBackspace
    Selection.TypeBackspace
End Sub

Invité · 19/08/2020, 03h09

Envoyé par Vincentfoug

Bonjour à tous,

A tester. Le temps de traitement devrait être très long si le document est volumineux, et il y a sans doute du code plus performant. Dans ce code, les accolades ne sont pas supprimées. Le cas échéant, il faudrait tronquer le contenu de MonRange.

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
 
Sub MettreEnGrasEntreAccolades()
 
Dim MonDocument As Document
Dim I As Long, DebutChaine As Long, IndexAccolades As Long
Dim MonRange As Range
Dim MatriceAccolades() As Variant
 
    Application.ScreenUpdating = False
 
    Set MonDocument = ActiveDocument
    With MonDocument
 
         IndexAccolades = 0
         .Range.Font.Bold = False
 
         For I = 1 To .Characters.Count
             If .Characters(I).Text = "{" Then DebutChaine = I
             If .Characters(I).Text = "}" And DebutChaine > 0 Then
                ReDim Preserve MatriceAccolades(1, IndexAccolades)
                MatriceAccolades(0, IndexAccolades) = DebutChaine - 1
                MatriceAccolades(1, IndexAccolades) = I
                IndexAccolades = IndexAccolades + 1
                DebutChaine = 0
             End If
         Next I
 
         If IndexAccolades > 0 Then
            For IndexAccolades = LBound(MatriceAccolades, 2) To UBound(MatriceAccolades, 2)
                Set MonRange = .Range
                MonRange.SetRange Start:=MatriceAccolades(0, IndexAccolades), End:=MatriceAccolades(1, IndexAccolades)
                MonRange.Font.Bold = True
                Set MonRange = Nothing
            Next IndexAccolades
         End If
 
    End With
    Set MonDocument = Nothing
 
    Application.ScreenUpdating = True
 
 
End Sub

Sinon pour comprendre, il vous faut déjà lire le tuto VBA Word : https://word.developpez.com/cours/
et la Faq : https://word.developpez.com/faq/

**Vincentfoug** · 19/08/2020, 20h48

Bonjour Eric,

Merci beaucoup de votre retour ! Effectivement c'est un peu long, mais pas grave.

Cependant j'ai des décalages vers la gauche qui se créent : les 3 premiers blocs "accolades" ok, ensuite le 4ème et 5ème se décalent d'un caractère vers la gauche :
Tige {longuement rampante et ramifiée}.

Le 6ème de 2 caractères vers la gauche, le 7ème de 4 caractères, et le décalage croit comme cela ensuite.

Si vous avez encore du temps à consacrer à ce problème...

Merci beaucoup

!!!

Invité · 20/08/2020, 02h58

Envoyé par Vincentfoug

Il faudrait mettre un exemple en ligne.

**Vincentfoug** · 20/08/2020, 23h47

Effectivement. J'en ai 600 pages. J'envoie un extrait demain soir.

Invité · 25/08/2020, 14h30

Envoyé par Vincentfoug

Comme suite à notre discussion, les chaînes à mettre en gras sont encadrées par ZZD et ZZF.

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
 
Sub RemplacementDesCaracteresEncadrants()
 
    Application.ScreenUpdating = False
    Selection.HomeKey unit:=wdStory
 
 
    'Recherche de toutes les expressions sous la forme "ZZD*ZZF"
    Do
        Selection.Find.ClearFormatting
        With Selection.Find
                .ClearFormatting
                .Text = "ZZD*ZZF"
                .Forward = True
                .Wrap = wdFindStop
                .MatchCase = True
                .MatchWildcards = True
                .MatchWholeWord = False
                .Execute
        End With
        If Selection.Find.Found Then Selection.Font.Bold = True
 
    Loop Until Not Selection.Find.Found
 
    Do
        Selection.Find.ClearFormatting
        With Selection.Find
                .ClearFormatting
                .Text = "ZZD"
                .Forward = True
                .Wrap = wdFindStop
                .MatchCase = True
                .MatchWildcards = True
                .Execute
        End With
        If Selection.Find.Found Then Selection.Text = ""
 
    Loop Until Not Selection.Find.Found
 
    Do
        Selection.Find.ClearFormatting
        With Selection.Find
                .ClearFormatting
                .Text = "ZZF"
                .Forward = True
                .Wrap = wdFindStop
                .MatchCase = True
                .MatchWildcards = True
                .Execute
        End With
 
        If Selection.Find.Found Then Selection.Text = ""
    Loop Until Not Selection.Find.Found
 
    Application.ScreenUpdating = True
 
End Sub

**Vincentfoug** · 25/08/2020, 21h26

Merci Eric !! Ça marche parfaitement et c'est adaptable !

Un dernier truc, je cherche à remettre en gras dans mon excel les phrases encadrées par mes accolades, j'ai trouvé cela, mais ça ne marche que sur une seule cellule, impossible (pour moi

) de l'appliquer à une feuille entière.

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
Sub test() 
Dim phrase As String, départ As Long, longueur As Long
With [A1]
.Font.FontStyle = "Normal"
phrase = .Value '
 
départ = InStr(phrase, "{") + 1
longueur = InStr(phrase, "}")
With .Characters(Start:=départ, Length:=longueur - départ).Font
.Name = "Book Antique"
.FontStyle = "Gras"
.Size = 8
End With
End With
 
End Sub

Invité · 26/08/2020, 04h15

Envoyé par Vincentfoug

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
 
Sub Test()
 
Dim Phrase As String
Dim I As Long, Depart As Long, Longueur As Long, DerniereLigne As Long
Dim AireABalayer As Range
 
    With ActiveSheet
 
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireABalayer = .Range("A1:A" & DerniereLigne)
 
         For I = 1 To AireABalayer.Count
             Depart = 0: Longueur = 0
             With AireABalayer(I)
                  .Font.FontStyle = "Normal"
                  Phrase = .Value '
                  Depart = InStr(Phrase, "{") + 1
                  Longueur = InStr(Phrase, "}")
                  'Debug.Print I & ", départ : " & Depart & ", longueur : " & Longueur
                  If Depart > 0 And Longueur > 0 Then
                     With .Characters(Start:=Depart, Length:=Longueur - Depart).Font
                          .Name = "Book Antique"
                          .FontStyle = "Gras"
                          .Size = 8
                     End With
                  End If
             End With
         Next I
 
         Set AireABalayer = Nothing
 
    End With
 
End Sub

**Vincentfoug** · 26/08/2020, 14h04

Bonjour Eric, c'est presque parfait, merci beaucoup !

Cela ne fonctionne pas si j'ai deux occurrences d'encadrement dans la même cellule, seule la première en mise en gras comme ci-dessous. Est-ce faisable d'y arriver pour 2 ou plus dans une même cellule ?

Feuilles {vert sombre} ou {panachées de jaune}, un peu coriaces et longues jusqu'à 7 cm, courtement pétiolées.

Merci !!

Invité · 26/08/2020, 14h34

Envoyé par Vincentfoug

Ce code permet d'isoler les différentes parties concernées dans chaque cellule. Il reste à construire le code avec Instr pour retrouver chacune des parties et la mettre en gras.

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
Sub Test2()
 
Dim Phrase As String
Dim I As Long, J As Long, Depart As Long, Longueur As Long, DerniereLigne As Long, IndexMatrice As Long
Dim AireABalayer As Range
Dim TableauAccolades As Variant
Dim MatriceAccolades() As Variant
 
 
    With ActiveSheet
 
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireABalayer = .Range("A1:A" & DerniereLigne)
         IndexMatrice = 0
         For I = 1 To AireABalayer.Count
             Depart = 0: Longueur = 0
             With AireABalayer(I)
                  TableauAccolades = Split(.Value, "{")
                  If UBound(TableauAccolades) > 0 Then
                     For J = LBound(TableauAccolades) To UBound(TableauAccolades)
                         Debug.Print I & ", " & TableauAccolades(J)
                         If InStr(1, TableauAccolades(J), "}", vbTextCompare) > 0 Then
                            ReDim Preserve MatriceAccolades(2, IndexMatrice)
                            MatriceAccolades(0, IndexMatrice) = I
                            MatriceAccolades(1, IndexMatrice) = Split(TableauAccolades(J), "}")(0)
                            IndexMatrice = IndexMatrice + 1
                          End If
 
                    Next J
                  End If
             End With
         Next I
 
         For IndexMatrice = LBound(MatriceAccolades, 2) To UBound(MatriceAccolades, 2)
             Debug.Print "Ligne : " & MatriceAccolades(0, IndexMatrice) & " : " & MatriceAccolades(1, IndexMatrice)
         Next IndexMatrice
 
        ' Ensuite on recherche dans chaque cellule de l'aire AireABalayer
        ' les chaînes contenues dans la matrice correspondant à la ligne dans MatriceAccolades(0, IndexMatrice)
        ' et avec Instr la présence de MatriceAccolades(1, IndexMatrice) dans la chaînes
 
 
         Set AireABalayer = Nothing
 
 
    End With
 
End Sub

**Vincentfoug** · 26/08/2020, 14h56

Je t'avouerais que je ne vois pas comment coder les instructions
' Ensuite on recherche dans chaque cellule de l'aire AireABalayer
' les chaînes contenues dans la matrice correspondant à la ligne dans MatriceAccolades(0, IndexMatrice)
' et avec Instr la présence de MatriceAccolades(1, IndexMatrice) dans la chaînes

Sélectionner pour appliquer gras à un ensemble de chaînes de caractères commençant finissant par un caractère

VBA Word

Discussions similaires

Partager

Partager