Discussion :

[rheylens]

Bonjour,

J'ai aujourd'hui un document Excel que nous utilisons pour le calcule de toute nos offerts (secteur traiteur) ou un onglet du fichier correspond à un type de produit (Apéritif maison, Apéritif champagne, Menu XXX, ... / en tout environ 100 onglets)

Lorsque tout le calcule est fait il existe déjà une routine qui permet de copie des zone définie du fichier Excel vers un document type Word (on colle le texte sur des signet dans le document Word)

Jusque la déjà une belle soupe pour gérer tout cela mais aujourd'hui on me demande d'ajouté une niveau de complexité à savoir que chaque titre de menu dans Excel devienne d'une façon ou d'une autre (automatique) un Style de Titre de Word pour pouvoir ensuite intégré une table des matière automatique. La je vous avoue je me prend la tête

J'ai eu bonne espoire lorsque je me suis rendu compte que les zone nommé devenait des signet dans Word lors du transfert (copy/past en VBA) mais deux problème se présente :
1. Le nom de la zone nommé n'est pas récupérer tel quel dans Word mais deviens RANGE suivis de la référence de la cellule
2. Si plusieurs onglet au final dans Word on retrouve le première signet du première onglet et les autres son ignoré car il porte le même nom vue que tout mes titres dans Excel sont dans la même cellule.

Quelqu'un pourrait-il m'aider ou aurait-il une idée lumineuse pour me solutionné ce problème ?

A savoir que dans mon Excel j'ai aussi une fonction de création de book qui met tout en place dans un fichier Word au départ de l'Excel ce qui fait au final quasi 150 page je ne peux donc pas demandé au utilisateur de refaire manuellement la mise en page à chaque fois.

Pour info encore le code qui copie les bloques de menu dans Word depuis Excel (je précise que j'ai hérité de ce code et que je dois donc faire avec )

La parie qui copie colle les tableau en 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
21
22
23
24
25
26
27
28
29
30
 
''''''''''''''''''''''''''''''
'  COPIE DES PAGES TEXTE     '
''''''''''''''''''''''''''''''
iInit = 6
i = iInit
iBlock = 1
 
Call ViderLePressePapier
 
Do While i < 48
    If FeuilleExiste(Feuil49.Range("A" & i)) Then
 
    Nom = Feuil49.Range("A" & i)
    Set strTab = Sheets(Nom)
    cordonnees = RechercheCoordoneesFin(Feuil49.Range("A" & i))
    strTab.Range(cordonnees).Copy
 
    LeDocWord.Bookmarks("TEXT" & iBlock).Range.PasteSpecial Link:=False
    .Bookmarks("SDP" & iBlock).Range.InsertBreak Type:=wdPageBreak 'inserer le saut de page
    LeDocWord.Collapse Direction:=wdCollapseEnd
 
    Call ViderLePressePapier
 
    Set strTab = Nothing
    iBlock = iBlock + 1
    End If
 
    i = i + 1
Loop

Et le Code complet du module pour qui veut

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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
 
Sub CreationOffreWord(Chemin, MonsieurMadame, RefSignature, RefCoSignature, AjoutBC As Variant)
 
Call TimingAfficherLigneNonVides
 
Dim Lettre As String
Dim ObjWord As Word.Application
Dim LeDocWord As Word.Document
Dim i As Integer
Dim iInit As Integer
Dim iBlock As Integer
Dim strTab As Worksheet
Dim Nom, test As String
 
On Error Resume Next
 
'Lettre = "J:\Service Commercial\BE - FR Offre commerciale - 1°courrier V15.doc"
Lettre = Chemin
 
'Gestion de l'erreur si le chemin est introuvable.
    If Dir(Lettre, vbDirectory) = "" Then
            MsgBox "Fichier non trouvé" & Chr(10) & "Veuillez sélectionner manuellement le fichier.", vbInformation
 
            ChDrive "J:"
            'Selectionne un repertoire sur ce disque
            ChDir "J:\Commercial\000 Offre 2010\02 Offre 2011\Lettres"
            Lettre = Application.GetOpenFilename
            'Exit Sub
 
    End If
 
Set ObjWord = CreateObject("Word.Application")
ObjWord.Visible = True
Set LeDocWord = ObjWord.Documents.Open(Lettre)
 
Societe = Sheets("Plantage").Range("Nom_du_Client")
PersonneContact = Sheets("Plantage").Range("Persone_de_Contact")
AdresseMail = Sheets("Plantage").Range("Contact_Email")
AdresseCourrier = Sheets("Plantage").Range("Contact_AdresseFacturation")
 
If Sheets("Plantage").Range("Contact_Gsm") = "" Then
    Telephone = Sheets("Plantage").Range("Contact_Telephone")
        Else
    Telephone = Sheets("Plantage").Range("Contact_Gsm")
End If
 
Reference = Sheets("Plantage").Range("NomduFichier")
 
With LeDocWord
 
'Copie des signets
.Bookmarks("Société").Range.Text = Societe
.Bookmarks("Contact").Range.Text = PersonneContact
.Bookmarks("eMail").Range.Text = AdresseMail
.Bookmarks("Tel").Range.Text = Telephone
.Bookmarks("Reference").Range.Text = Reference
.Bookmarks("MonsieurMadame").Range.Text = MonsieurMadame
.Bookmarks("Adresse").Range.Text = AdresseCourrier
 
'ATTENTION. Ces 2 Signets en dessous vont varier en fonction de la langue.
 
Dim TexteComission, TexteCondition, TexteVersionOffre As String
 
Select Case CreaWord.ComboBoxLangue.Value
 
Case "FR"
    TexteComission = Sheets("Signature").Range("a30")
    TexteCondition = Sheets("Signature").Range("a28")
 
    If Sheets("Plantage").Range("StatutOffre") <> "V1" Then 'Nouvelle offre
        TexteVersionOffre = Sheets("Signature").Range("a34")
    Else '1er offre
        TexteVersionOffre = Sheets("Signature").Range("a32")
    End If
 
Case "NL"
    TexteComission = Sheets("Signature").Range("c30")
    TexteCondition = Sheets("Signature").Range("C28")
 
    If Sheets("Plantage").Range("StatutOffre") <> "V1" Then 'Nouvelle offre
        TexteVersionOffre = Sheets("Signature").Range("c34")
    Else '1er offre
        TexteVersionOffre = Sheets("Signature").Range("c32")
    End If
 
Case "UK"
    TexteComission = Sheets("Signature").Range("e30")
    TexteCondition = Sheets("Signature").Range("e28")
 
    If Sheets("Plantage").Range("StatutOffre") <> "V1" Then 'Nouvelle offre
        TexteVersionOffre = Sheets("Signature").Range("e34")
    Else '1er offre
        TexteVersionOffre = Sheets("Signature").Range("e32")
    End If
End Select
 
' Affichage de la version de l'offre
.Bookmarks("VersionOffre").Range.Text = TexteVersionOffre
 
' Affichage du texte sur les conditions de site que si aucune comissions.
If Feuil7.Range("ComissionTotal") = 0 Then
.Bookmarks("comission").Range.Text = TexteComission
'si il y a comission il ne faut pas prévenir le client.
Else
.Bookmarks("comission").Range.Text = " "
End If
 
' Affichage des "Conditions en régie" si le nombre d'invités est inférieur à 150.
If Feuil49.Range("b6") < 150 Then
.Bookmarks("Condition").Range.Text = TexteCondition
 
Else
.Bookmarks("Condition").Range.Text = ""
End If
 
''''''''''''
'Tableau Timing
Sheets("Timing").Visible = True
ThisWorkbook.Sheets("Timing").Range("C5:K43").Copy
LeDocWord.Bookmarks("Timing").Range.PasteSpecial Link:=False
Sheets("Timing").Visible = False
 
'Monsieur Madame ou Mademoiselle
.Bookmarks("MonsieurMadame2").Range.Text = MonsieurMadame
 
'Signature
Sheets("Signature").Visible = True
ThisWorkbook.Sheets("Signature").Range(RefSignature).Copy
LeDocWord.Bookmarks("Signature").Range.PasteSpecial
 
'Cosignature
ThisWorkbook.Sheets("Signature").Range(RefCoSignature).Copy
LeDocWord.Bookmarks("CoSignature").Range.PasteSpecial
LeDocWord.Bookmarks("CoSignature").Range.InsertBreak Type:=wdPageBreak
Sheets("Signature").Visible = False
 
''''''''''''''''''''''''''''''
'  COPIE DES PAGES TEXTE     '
''''''''''''''''''''''''''''''
iInit = 6
i = iInit
iBlock = 1
 
Call ViderLePressePapier
 
Do While i < 48
    If FeuilleExiste(Feuil49.Range("A" & i)) Then
 
    Nom = Feuil49.Range("A" & i)
    Set strTab = Sheets(Nom)
    cordonnees = RechercheCoordoneesFin(Feuil49.Range("A" & i))
    strTab.Range(cordonnees).Copy
 
    LeDocWord.Bookmarks("TEXT" & iBlock).Range.PasteSpecial Link:=False
    .Bookmarks("SDP" & iBlock).Range.InsertBreak Type:=wdPageBreak 'inserer le saut de page
    LeDocWord.Collapse Direction:=wdCollapseEnd
 
    Call ViderLePressePapier
 
    Set strTab = Nothing
    iBlock = iBlock + 1
    End If
 
    i = i + 1
Loop
 
'Tableau Recap Client
  ThisWorkbook.Sheets("L'Estimation Budgétaire Client").Range("A4:F128").Copy
  LeDocWord.Bookmarks("EstimationBudgetaire").Range.PasteSpecial Link:=False
 
'Tableau Estim Conso
If Worksheets("EstimConso").Visible = True Then
  ThisWorkbook.Sheets("EstimConso").Range("A1:G11").Copy
  LeDocWord.Bookmarks("EstimConso").Range.PasteSpecial Link:=False
End If
 
''''''''''''''''''''''''''''''
'  COPIE TABLEAU RECAP       '
''''''''''''''''''''''''''''''
If Feuil53.CheckBox7.Value = True Then
  ThisWorkbook.Sheets("L'Estimation Budgétaire Client").Range("A132:E140").Copy
  LeDocWord.Bookmarks("TableauRecap").Range.PasteSpecial Link:=False
 
End If
 
''''''''''''''''''''''''''''''
'  COPIE BON DE COMMANDE     '
''''''''''''''''''''''''''''''
Call ViderLePressePapier
 
If Feuil7.Range("StatutOffre").Value = "Confirmation" Then
 
    Dim LangueBDC, NomFeuilleBDC As String
    LangueBDC = Feuil57.Range("LangueTrad")
 
    Select Case LangueBDC
        Case "FR"
            Feuil10.Visible = True
            Feuil10.Select
 
        Case "NL"
            Feuil14.Visible = True
            Feuil14.Select
 
        Case "UK"
            Feuil39.Visible = True
            Feuil39.Select
 
        Case Else
            Feuil10.Visible = True
            Feuil10.Select
 
    End Select
 
    NomFeuilleBDC = "Bon de Commande " & LangueBDC
 
    Sheets(NomFeuilleBDC).Range("A1:H68").Copy
 
    LeDocWord.Bookmarks("SDPbc").Range.InsertBreak Type:=wdPageBreak
    LeDocWord.Bookmarks("BonDeCommande").Range.PasteSpecial Link:=False
 
Else
    LeDocWord.Bookmarks("SDPbc").Range.Text = " "
End If
End With 'fin du travail dans le document.
 
'***********************************************************************
' Enregistrer l'offre suivant la référence du dossier.
      NomFichier = ThisWorkbook.Path & "\" & Feuil7.Range("NomduFichier").Value
      LeDocWord.SaveAs NomFichier
'***********************************************************************
 
'Quitter Word
'ObjWord.Quit
    Call ViderLePressePapier
 
'reoutner à word une fois tout terminé
ObjWord.WindowState = xlMaximized
AppActivate "Microsoft Word"
 
'Set ObjWord = Nothing
 
End Sub

[78chris]

Bonjour

Je n'ai pas détaillé ton code mais il faut un seul style, Titre1 par exemple, appliqué à la donnée qui sert de titre pour chaque bloc.
Soit copier en 2 fois, éventuellement en prévoyant un signet pour le titre et un autre pour les autres lignes,
soit retrouver après collage le signet qui vient d'être utilisé, ce qui doit te positionner sur le 1er paragraphe puis appliquer Titre1.

Cela peut aussi être une routine en fin de process qui balaye le contenu de signet en signet, et applique le style au 1er paragraphe.

[rheylens]

J'y avais songé mais après le colle le signe n'existe plus...

[78chris]

Re

J'y avais songé mais après le colle le signe n'existe plus...

Code à revoir car on peut coller sans les effacer. Sinon reste l'option copier/coller en 2 fois, le titre puis le reste

[rheylens]

Bonjour,

Je ne vois pas trop quoi changer au niveau de la ligne de code qui colle le texte pour garder les balises j'ai déjà essayer quelques variante mais les balise sont chaque fois mangée.

Code :

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

1
2
3
4
5
6
7
 
Dim ObjWord As Word.Application
Dim LeDocWord As Word.Document
Dim strTab As Worksheet
 
strTab.Range(cordonnees).Copy
LeDocWord.Bookmarks("TEXT" & iBlock).Range.PasteSpecial Link:=False

[78chris]

Bonjour

2 solutions ici http://www.developpez.net/forums/d48...truire-signet/