Réorganiser les paragraphes dans un texte selon leur style

**florent** · 11/09/2017, 14h36

Bonjour,

je souhaite réorganiser du texte en me basant sur le style des paragraphes
Il s'agit de traductions de textes où la traduction a été organisée paragraphe par paragraphe, la traduction étant finie je souhaite séparée la partie originale et la traduite.

Voici comment est organisé :

Titre du texte 1 [Style Titre1]

Paragraphe 1 en langue d'origine [Style Paragraphe Quechua]

Paragraphe 1 traduit en français [Style Normal]

Paragraphe 2 en langue d'origine [Style Paragraphe Quechua]

Paragraphe 2 traduit en français [Style Normal]
.....

Titre du texte 2 [Style Titre1]

Paragraphe 1 en langue d'origine [Style Paragraphe Quechua]

Paragraphe 1 traduite en français [Style Normal]
.....

Le résulat souhaite est le suivant :

Titre du texte 1 [Style Titre1 Quechua]

Paragraphe 1 en langue d'origine [Style Paragraphe Quechua]
Paragraphe 2 en langue d'origine [Style Paragraphe Quechua]
....

Titre du texte 1 [Style Titre1 Français]
Paragraphe 1 traduit en français [Style Paragraphe Français]
Paragraphe 2 traduit en français [Style Paragraphe Français]
.....

Titre du texte 2 [Style Titre1 Quechua]
Paragraphe 1 en langue d'origine [Style Paragraphe Quechua]
....

Titre du texte 2 [Style Titre1 Français]
Paragraphe 1 traduite en français [Style Paragraphe Français]
.....

J'avais réussi à faire la réorganisation en recopiant le texte ( avec le champ Paragraph.Range.Text) mais je perdais les notes de bas de page.
J'ai voulu refaire le script avec les méthode Copy/Paste mais je bloque.

Voici mon code, je bloque principalement sur la mise en variable de la sélection copiée

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
 
Sub A_split()
    Dim App As Application
    Dim para As Paragraph
 
    Dim target As Document
    Dim source As Document
 
    Set source = ActiveDocument
    Set target = Documents.Add("S:\Public\Users\Florent\Google Drive\Modèle mémoire quechua-fr.dotm", NewTemplate:=False, DocumentType:=0)
 
' Ajout de deux signets pour insérer le texte original et sa traduction
    target.Bookmarks.Add ("book_original")
    target.Bookmarks.Add ("book_traduct")
 
    For Each para In source.Paragraphs
        Dim SelectPara As Selection
        para.Range.Select
 
' C'est ici que rien ne fonctionne
'        Set SelectPara = App.Selection
        Selection.Copy
 
 
        If para.Style = "Titre 1" Then
            RemplirSignet target, "book_original", SelectPara ', "Titre 1 Quechua"
            RemplirSignet target, "book_traduct", SelectPara ', "Titre 1 Français"
        End If
 
        If para.Style = "Normal" Then
            RemplirSignet target, "book_traduct", SelectPara ', "Paragraphe Français"
        End If
 
        If para.Style = "Paragraphe Quechua" Then
            RemplirSignet target, "book_original", SelectPara ', "Paragraphe Quechua"
        End If
 
    Next para
End Sub
 
Public Function RemplirSignet(Doc As Document, A As String, B As Selection) ', C As Style)
' Remplit le signet A avec le texte B sans détruire A
On Error GoTo sortie
Dim Place As Long
 
Place = Doc.Bookmarks(A).Range.Start
Doc.Bookmarks(A).Range = B.Paste
Doc.Bookmarks.Add Name:=A, Range:=ActiveDocument.Range(Place, Place + Len(B))
sortie:
End Function

Merci

Invité · 11/09/2017, 20h27

Envoyé par florent

Bonsoir,

En imaginant que votre document soit dupliqué, le code suivant supprime les styles choisis dans chacun des documents :

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
 
 
Sub SupprimerLesParagraphesDUnStyle(ByVal DocEncours As Document, ByVal LeStyleASupprimer As String)
 
Dim I As Long
 
    With DocEncours
         For I = .Paragraphs.Count To 1 Step -1
             If .Paragraphs(I).Style = LeStyleASupprimer Then .Paragraphs(I).Range.Delete
         Next I
    End With
 
End Sub
 
 
Sub TesterSupprimerLesParagraphesDUnStyle()
 
Dim DocumentNormal As Document
Dim DocumentQuecha As Document
 
    Set DocumentNormal = Documents("Doc1.docm")
    SupprimerLesParagraphesDUnStyle DocumentNormal, "Paragraphe Quechua"
    Set DocumentNormal = Nothing
 
    Set DocumentQuecha = Documents("Doc2.docm")
    SupprimerLesParagraphesDUnStyle DocumentQuecha, "Normal"
    Set DocumentQuecha = Nothing
 
End Sub

Une fois les suppressions terminées, vous pouvez faire un copier-coller d'un des documents sur le deuxième.

**florent** · 11/09/2017, 22h29

Bonsoir Eric,

Merci pour ce retour, c'est en effet une méthode envisageable, mais il faut absolument que les deux versions du texte se succèdent, si bien qu'au début j'avais envisagé de déplacer le texte à l'intérieur même du document, cela m'a vite semblé trop complexe donc je me suis orienté vers la recopie dans un document nouveau.

Cela étant, je reste curieux de comprendre pourquoi je n'arrive pas stocker dans une variable la sélection (via un Range.Copy pour conserver les notes de bas de page) et le transmettre à une fonction.

Cordialement
Florent

Invité · 12/09/2017, 16h11

Envoyé par florent

Mon précédent code organisait les paragraphes selon l'ordre des styles. En passant par des matrices de position, les paragraphes apparaissent dans l'ordre des titres puis des styles.

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
 
Sub OrganiserLesTraductions()
 
Dim DocSource As Document, DocCible As Document
Dim ParagrapheTitre As Paragraph
Dim MatriceDesTitres() As Variant, MatriceStyleNormal() As Variant, MatriceStyleQuechua() As Variant
Dim I As Integer, J As Integer
Dim NbParagraphesTitre As Integer, NbParagraphesNormaux As Integer, NbParagraphesQuechua As Integer
Dim MonRangeTitre As Range, MonRangeCible As Range
Dim StyleTitre As String, StyleNormal As String, StyleQuechua As String, Titre1EnCours As String
 
 
    StyleTitre = "Titre 1"
    StyleNormal = "Normal"
    StyleQuechua = "Sous-titre"  ' A adapter
 
    Set DocSource = ActiveDocument
    With DocSource
 
         NbParagraphesTitre = 0
         NbParagraphesNormaux = 0
         NbParagraphesQuechua = 0
 
         For I = 1 To .Paragraphs.Count
 
             Select Case .Paragraphs(I).Style
                    Case StyleTitre
                           Titre1EnCours = .Paragraphs(I).Range.Text
                           ReDim Preserve MatriceDesTitres(1, NbParagraphesTitre)
                           MatriceDesTitres(0, NbParagraphesTitre) = Titre1EnCours
                           MatriceDesTitres(1, NbParagraphesTitre) = I
                           NbParagraphesTitre = NbParagraphesTitre + 1
                    Case StyleNormal
                           ReDim Preserve MatriceStyleNormal(1, NbParagraphesNormaux)
                           MatriceStyleNormal(0, NbParagraphesNormaux) = Titre1EnCours
                           MatriceStyleNormal(1, NbParagraphesNormaux) = I
                           NbParagraphesNormaux = NbParagraphesNormaux + 1
                    Case StyleQuechua
                           ReDim Preserve MatriceStyleQuechua(1, NbParagraphesQuechua)
                           MatriceStyleQuechua(0, NbParagraphesQuechua) = Titre1EnCours
                           MatriceStyleQuechua(1, NbParagraphesQuechua) = I
                           NbParagraphesQuechua = NbParagraphesQuechua + 1
             End Select
         Next I
 
    End With
 
    Set DocCible = Documents.Add
    With DocCible
 
         For I = LBound(MatriceDesTitres, 2) To UBound(MatriceDesTitres, 2)
 
             Set MonRangeTitre = DocSource.Paragraphs(MatriceDesTitres(1, I)).Range
             MonRangeTitre.Copy
             .Paragraphs.Add
             Selection.Paste
 
 
            For J = LBound(MatriceStyleQuechua, 2) To UBound(MatriceStyleQuechua, 2)
                If MatriceStyleQuechua(0, J) = MatriceDesTitres(0, I) Then
                   Set MonRangeCible = DocSource.Paragraphs(MatriceStyleQuechua(1, J)).Range
                   MonRangeCible.Copy
                   .Paragraphs.Add
                   Selection.Paste
                   Set MonRangeCible = Nothing
                End If
            Next J
 
            MonRangeTitre.Copy
            .Paragraphs.Add
            Selection.Paste
 
            For J = LBound(MatriceStyleNormal, 2) To UBound(MatriceStyleNormal, 2)
                If MatriceStyleNormal(0, J) = MatriceDesTitres(0, I) Then
                   Set MonRangeCible = DocSource.Paragraphs(MatriceStyleNormal(1, J)).Range
                   MonRangeCible.Copy
                   .Paragraphs.Add
                   Selection.Paste
                   Set MonRangeCible = Nothing
                End If
            Next J
 
            Set MonRangeTitre = Nothing
         Next I
 
    End With
    Set DocCible = Nothing
    Set DocSource = Nothing
 
End Sub

**florent** · 12/09/2017, 23h24

Bonsoir Eric,

tout d'abord milles merci pour ce code, j'apprécie le temps que tu y as consacré !

Je continue d'ajouter des fonctionnalités au code pour mes besoins, notamment la mise en forme après le paste, la seule méthode que j'ai trouvé et la mise en place d'un compteur que j'incrémente à chaque Paragraph.Add mais je ne trouve pas cela très élégant. aurais-je pu faire mieux ?

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
            MonRangeTitre.Copy
            .Paragraphs.Add
            Selection.Paste
            .Paragraphs(Pos).Style = ActiveDocument.Styles("Titre 1 Français")
            Pos = Pos + 1
 
            For J = LBound(MatriceStyleNormal, 2) To UBound(MatriceStyleNormal, 2)
                If MatriceStyleNormal(0, J) = MatriceDesTitres(0, I) Then
                   Set MonRangeCible = DocSource.Paragraphs(MatriceStyleNormal(1, J)).Range
                   MonRangeCible.Copy
                   .Paragraphs.Add
                   Selection.Paste
                   .Paragraphs(Pos).Style = ActiveDocument.Styles("Paragraphe Français")
                   Pos = Pos + 1
                   Set MonRangeCible = Nothing
                End If
            Next J

j'ai aussi un comportement bizarre, il me génère beaucoup de caractères "Entrée" (char 13) à la fin du document, as tu constaté le même fonctionnement ?

Merci encore

Invité · 13/09/2017, 04h06

Envoyé par florent

aurais-je pu faire mieux ?

Il faut modifier la sélection en cours après avoir collé le titre qui doit être de style Quechua en première partie. Exemple :

Code :

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

1
2
3
4
5
6
7
8
9
 
             With Selection
                .Paste
                .MoveUp unit:=wdLine, Count:=1
                .EndKey unit:=wdLine, Extend:=wdExtend
                .Style = StyleQuechua
                .MoveDown unit:=wdLine, Count:=1
                'MsgBox .Range.Text
             End With

Le code devient :

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
 
Sub OrganiserLesTraductions()
 
Dim DocSource As Document, DocCible As Document
Dim ParagrapheTitre As Paragraph
Dim MatriceDesTitres() As Variant, MatriceStyleNormal() As Variant, MatriceStyleQuechua() As Variant
Dim I As Integer, J As Integer
Dim NbParagraphesTitre As Integer, NbParagraphesNormaux As Integer, NbParagraphesQuechua As Integer
Dim MonRangeTitre As Range, MonRangeCible As Range
Dim StyleTitre As String, StyleNormal As String, StyleQuechua As String, Titre1EnCours As String
 
 
    StyleTitre = "Titre 1"
    StyleNormal = "Normal"
    StyleQuechua = "Sous-titre"  ' A adapter
 
    Set DocSource = ActiveDocument
    With DocSource
 
         NbParagraphesTitre = 0
         NbParagraphesNormaux = 0
         NbParagraphesQuechua = 0
 
         For I = 1 To .Paragraphs.Count
 
             Select Case .Paragraphs(I).Style
                    Case StyleTitre
                           Titre1EnCours = .Paragraphs(I).Range.Text
                           ReDim Preserve MatriceDesTitres(1, NbParagraphesTitre)
                           MatriceDesTitres(0, NbParagraphesTitre) = Titre1EnCours
                           MatriceDesTitres(1, NbParagraphesTitre) = I
                           NbParagraphesTitre = NbParagraphesTitre + 1
                    Case StyleNormal
                           ReDim Preserve MatriceStyleNormal(1, NbParagraphesNormaux)
                           MatriceStyleNormal(0, NbParagraphesNormaux) = Titre1EnCours
                           MatriceStyleNormal(1, NbParagraphesNormaux) = I
                           NbParagraphesNormaux = NbParagraphesNormaux + 1
                    Case StyleQuechua
                           ReDim Preserve MatriceStyleQuechua(1, NbParagraphesQuechua)
                           MatriceStyleQuechua(0, NbParagraphesQuechua) = Titre1EnCours
                           MatriceStyleQuechua(1, NbParagraphesQuechua) = I
                           NbParagraphesQuechua = NbParagraphesQuechua + 1
             End Select
         Next I
 
    End With
 
    Set DocCible = Documents.Add
    With DocCible
 
         For I = LBound(MatriceDesTitres, 2) To UBound(MatriceDesTitres, 2)
 
             Set MonRangeTitre = DocSource.Paragraphs(MatriceDesTitres(1, I)).Range
             MonRangeTitre.Copy
             .Paragraphs.Add
             With Selection
                .Paste
                .MoveUp unit:=wdLine, Count:=1
                .EndKey unit:=wdLine, Extend:=wdExtend
                .Style = StyleQuechua
                .MoveDown unit:=wdLine, Count:=1
                'MsgBox .Range.Text
             End With
 
 
            For J = LBound(MatriceStyleQuechua, 2) To UBound(MatriceStyleQuechua, 2)
                If MatriceStyleQuechua(0, J) = MatriceDesTitres(0, I) Then
                   Set MonRangeCible = DocSource.Paragraphs(MatriceStyleQuechua(1, J)).Range
                   MonRangeCible.Copy
                   .Paragraphs.Add
                   Selection.Paste
                   Set MonRangeCible = Nothing
                End If
            Next J
 
            MonRangeTitre.Copy
            .Paragraphs.Add
            Selection.Paste
 
            For J = LBound(MatriceStyleNormal, 2) To UBound(MatriceStyleNormal, 2)
                If MatriceStyleNormal(0, J) = MatriceDesTitres(0, I) Then
                   Set MonRangeCible = DocSource.Paragraphs(MatriceStyleNormal(1, J)).Range
                   MonRangeCible.Copy
                   .Paragraphs.Add
                   Selection.Paste
                   Set MonRangeCible = Nothing
                End If
            Next J
 
            Set MonRangeTitre = Nothing
         Next I
 
    End With
    Set DocCible = Nothing
    Set DocSource = Nothing
 
End Sub

j'ai aussi un comportement bizarre, il me génère beaucoup de caractères "Entrée" (char 13) à la fin du document, as tu constaté le même fonctionnement ?

Non, car mon document ne fait qu'une page et je lui ai ajouté deux à trois notes de bas de page et une note de fin. Il y a peut-être d'autres objets qui sont passés à la trappe dans cette transformation. Si c'est à la fin, cela ne doit pas être trop gênant.

Invité · 13/09/2017, 11h00

Envoyé par florent

j'ai aussi un comportement bizarre, il me génère beaucoup de caractères "Entrée" (char 13) à la fin du document, as tu constaté le même fonctionnement ?

Le code ci-dessous supprime les lignes vides et décroche au premier paragraphe non vide.

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
 
Sub SupprimerLesLignesVides(ByVal DocEnCours As Document)
 
Dim J As Integer, NbRemplacements As Integer
 
   ' NbRemplacements = 0
    With DocEnCours
         For J = .Paragraphs.Count To 1 Step -1
             With .Paragraphs(J)
                  If Len(.Range.Text) = 1 Then
                     'NbRemplacements = NbRemplacements + 1
                     .Range.Delete
                  Else
                    Exit For
                  End If
 
             End With
         Next J
    End With
    'MsgBox NbRemplacements
 
End Sub

Procédure à insérer dans le code principal

Code :

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

1
2
3
4
5
6
7
8
 
    SupprimerLesLignesVides DocCible
 
    End With
    Set DocCible = Nothing
    Set DocSource = Nothing
 
End Sub

Réorganiser les paragraphes dans un texte selon leur style

VBA Word

Discussions similaires

Partager

Partager