Discussion :

[hedidev1]

Bonjour,

j'ai les noms de paragraphes et sous paragraphes dans des colonnes excel (numero en B, nom en C) je coches alors ceux que je veux et en apuyant sur le bouton, il faut qu'il exporte d'un doc word a un autre les paragraphes voulus renumérotés (pour commencer a 1 et pas que le suivant soit 5) et en gardant la mise en forme.

Le probleme: il ne met pas en forme les titres de paragraphes (le 1 , 2, 3) mais il met en forme les 1.1, 1.2 ... et il ne renumérote pas bien les paragraphes.

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
Sub Bouton2_Clic()
 
Dim oWdApp As Object
Dim oWdDoc As Object
Dim oWdDocExp As Object
Dim rng1 As Word.Range
Dim rng2 As Word.Range
Dim strTheText As String
Dim Debut As String
Dim Fin As String
 
Set oWdApp = CreateObject("Word.Application")
oWdApp.Visible = True
Set oWdDocExp = oWdApp.Documents.Add
 
Set oWdDoc = GetObject("C:\Users\K010354\Desktop\Proposition CdC modèle_extrait.docx")
 
For i = 5 To Range("C5").End(xlDown).Row
If Range("B" & i).Interior.ColorIndex = 3 Then
Debut = Range("D" & i).Value
Fin = Range("D" & i + 1).Value
    Set rng1 = oWdDoc.Range
    If rng1.Find.Execute(FindText:="^p" & Debut) Then
        Set rng2 = oWdDoc.Range(rng1.Start, oWdDoc.Range.End)
        If rng2.Find.Execute(FindText:="^p" & Fin) Then
            oWdDoc.Range(rng1.Start, rng2.Start).Copy
            oWdDocExp.Parent.Selection.Paste
        End If
    End If
End If
Next i
 
End Sub

[hedidev1]

J'ai trouvé le probleme, je pense il faut importer les styles du document de base.

merci

[hedidev1]

Probleme non resolu, il y a des titre de paragraphes qui sont collés sans mise en forme et sans numeros et du coup les numeros de paragraphes ne sont pas correct.
Cela se produit sur les grands titre (1., 2.) pas les 1.1. ect, au fait apres un grand titre il y a direectement le petit titre, cela doit etre l'origine du probleme. De plus il y a un sommaire et une page est laissée blanche a la place du sommaire sur le nouveau doc, il faut que le collage se fasse au debut.



Merci pour votre aide

[hedidev1]

Du coup si il n'y a pas de solution on peut peut etre forcer en sautant une ligne entre 1 et 1.1, si quelqu'un a une idee ce serait gentil. Je cherche de ce coté.

[hedidev1]

Bonjour,

j'ai les noms de paragraphes et sous paragraphes dans des colonnes excel (numero en B, nom en C) je coches alors ceux que je veux, et en apuyant sur le bouton, il faut qu'il exporte d'un doc word a un autre les paragraphes voulus renumérotés (pour commencer a 1 et pas que le suivant soit 5) et en gardant la mise en forme.

Le probleme: il ne met pas en forme les titres de paragraphes (le 1 , 2, 3) mais il met en forme les 1.1, 1.2 ... et il ne renumérote pas bien les paragraphes.
Le probleme se pose au fait quand il n'y a rien entre 1. test et 1.1 test2. Une solution qui a marché sur un doc et d'inserer quelque chose entre 2 paragraphes mais ca ne veut pas inserer tout le temps (j'ai essayé InsertParagraphAfter).

Autre probleme: Quand je cherche 2. Tes et qu'il y a 1. Test avant, il choisit 1. Test.
J'ai essayé avec MatchWholeWord mais ca ne fonctionne pas.

Merci ! voila le 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
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
Sub Bouton2_Clic()
 
Dim oWdApp As Object
Dim oWdDoc As Object
Dim oWdDocExp As Object
Dim oRng1 As Object
Dim oRng2 As Object
Dim sDebut As String
Dim sFin As String
 
Set oWdApp = CreateObject("Word.Application")
oWdApp.Visible = True
Set oWdDocExp = oWdApp.Documents.Add
If bWordIsOpen(Cells(Chemin_L, Chemin_C + 1).Value) = False Then
    Set oWdApp = CreateObject("Word.Application")
    oWdApp.Visible = True
    Set oWdDoc = oWdApp.Documents.Open(Cells(Chemin_L, Chemin_C + 1).Value)
ElseIf bWordIsOpen(Cells(Chemin_L, Chemin_C + 1).Value) = True Then
    Set oWdDoc = GetObject(Cells(Chemin_L, Chemin_C + 1).Value)
End If
 
For i = Cocher_L + 2 To Cells(Cocher_L + 2, Cocher_C + 2).End(xlDown).Row
    If Cells(i, Cocher_C).Interior.ColorIndex = 3 Then
        sDebut = Cells(i, Cocher_C + 2).Value
        sFin = Cells(i + 1, Cocher_C + 2).Value
 
        'If Cells(i, Cocher_C + 1) Like "?" Then
            'Set oRng1 = oWdDoc.Range
              '  If oRng1.Find.Execute(FindText:="^p" & sDebut) Then
               '     oRng1.InsertParagraphAfter
              '  End If
       ' End If
 
        If sFin <> "" Then
            Set oRng1 = oWdDoc.Range
                If oRng1.Find.Execute(FindText:="^p" & sDebut, MatchWholeWord:=False) Then
                    oRng1.InsertParagraphAfter
                    Set oRng2 = oWdDoc.Range(oRng1.Start, oWdDoc.Range.End)
                        If oRng2.Find.Execute(FindText:="^p" & sFin, MatchWholeWord:=False) Then
                            oWdDoc.Range(oRng1.Start, oRng2.Start).Copy
                            oWdDocExp.Parent.Selection.Paste
                        End If
                End If
        ElseIf sFin = "" Then
            Set oRng1 = oWdDoc.Range
                If oRng1.Find.Execute(FindText:="^p" & sDebut, MatchWholeWord:=False) Then
                    oRng1.InsertParagraphAfter
                    oWdDoc.Range(oRng1.Start).Copy
                    oWdDocExp.Parent.Selection.Paste
                End If
        End If
    End If
Next i
 
'rDeb = oWdDocExp.Parent.Selection.GoTo(What:=wdGoToPage, Which:=wdGoToNext, Name:=1).Start
'rFin = oWdDocExp.Parent.Selection.GoTo(What:=wdGoToPage, Which:=wdGoToNext, Name:=2).Start
'oWdDocExp.Range(rDeb, rFin).Delete
 
End Sub
 
Function bWordIsOpen(sPath As String) As Boolean
 
    Dim oWdApp As Object
    Dim oWdDoc As Object
 
    On Error Resume Next
 
    Set oWdApp = GetObject(, "Word.Application")
    Set oWdDoc = oWdApp.Documents(sPath)
    On Error GoTo 0
    If oWdDoc Is Nothing Then
        bWordIsOpen = False
        Else
        bWordIsOpen = True
    End If
 
End Function

[hedidev1]

Au final je cherche a recuperer les paragraphes grace aux numeros/lettre 1.1. ... et les renuméroter en gardant la hiérarchie (hiérarchie 3 : 1.1.1)

Edit: J'arrive a recuperer les paragraphes mais en cherchant le titre du paragraphe, or ce mot peut aparaitre n'importe ou dans le doc, de plus il faudra rechercher 1. Titre et que ca ne trouve pas a la place un 2. Titre2 par exemple (car titre est inclu dans titre 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
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
Sub Bouton2_Clic()
 
Dim oWdApp As Object
Dim oWdDoc As Object
Dim oWdDocExp As Object
Dim oRng1 As Object
Dim oRng2 As Object
Dim sDebut As String
Dim sFin As String
Dim oRng3 As Object
Dim oRng4 As Object
 
Set oWdApp = CreateObject("Word.Application")
oWdApp.Visible = True
Set oWdDocExp = oWdApp.Documents.Add
If bWordIsOpen(Cells(Chemin_L, Chemin_C + 1).Value) = False Then
    Set oWdApp = CreateObject("Word.Application")
    oWdApp.Visible = True
    Set oWdDoc = oWdApp.Documents.Open(Cells(Chemin_L, Chemin_C + 1).Value)
ElseIf bWordIsOpen(Cells(Chemin_L, Chemin_C + 1).Value) = True Then
    Set oWdDoc = GetObject(Cells(Chemin_L, Chemin_C + 1).Value)
End If
 
For i = Cocher_L + 2 To Cells(Cocher_L + 2, Cocher_C + 2).End(xlDown).Row
    If Cells(i, Cocher_C).Interior.ColorIndex = 3 Then
        sDebut = Cells(i, Cocher_C + 2).Value
        sFin = Cells(i + 1, Cocher_C + 2).Value
    For j = i + 1 To Cells(Cocher_L + 2, Cocher_C + 2).End(xlDown).Row
    If Cells(j, Cocher_C).Interior.ColorIndex = 3 Then
    sFinexp = Cells(j, Cocher_C + 1).Value
    Exit For
    End If
    Next
 
        If sFin <> "" Then
            Set oRng1 = oWdDoc.Range
                If oRng1.Find.Execute(FindText:=sDebut) Then
                    Set oRng2 = oWdDoc.Range(oRng1.Start, oWdDoc.Range.End)
                        If oRng2.Find.Execute(FindText:=sFin) Then
                            oWdDoc.Range(oRng1.Start, oRng2.Start).Copy
                            oWdDocExp.Parent.Selection.Paste
                        End If
 
                End If
                                       Set oRng3 = oWdDocExp.Range
                            If oRng3.Find.Execute(FindText:=sDebut) Then
                           Set oRng4 = oWdDocExp.Range(oRng3.Start, oWdDocExp.Range.End)
                        If oRng4.Find.Execute(FindText:=sFinexp) Then
                            oWdDocExp.Range(oRng3.Start, oRng4.Start).SetListLevel (Len(Replace(Cells(i, Cocher_C + 2).Value, ".", "")))
                            End If
                            End If
        ElseIf sFin = "" Then
            Set oRng1 = oWdDoc.Range
                If oRng1.Find.Execute(FindText:=sDebut) Then
                    oWdDoc.Range(oRng1.Start).Copy
                    oWdDocExp.Parent.Selection.Paste
                End If
                                  Set oRng3 = oWdDocExp.Range
                            If oRng3.Find.Execute(FindText:=sDebut) Then
                           Set oRng4 = oWdDocExp.Range
 
                            oWdDocExp.Range(oRng3.Start, oRng4.End).SetListLevel (Len(Replace(Cells(i, Cocher_C + 2).Value, ".", "")))
                            End If
 
        End If
    End If
Next i
End Sub
 
Function bWordIsOpen(sPath As String) As Boolean
 
    Dim oWdApp As Object
    Dim oWdDoc As Object
 
    On Error Resume Next
 
    Set oWdApp = GetObject(, "Word.Application")
    Set oWdDoc = oWdApp.Documents(sPath)
    On Error GoTo 0
    If oWdDoc Is Nothing Then
        bWordIsOpen = False
        Else
        bWordIsOpen = True
    End If
 
End Function