VBA Excel vers Word signet et format
Bonjour à tous,
J'ai un petit soucis avec une macro qui permet en quelque sorte de faire du publipostage (mais de manière plus poussé, donc ce n'en est pas à proprement parler). Des données d'Excel sont envoyé vers Word en allant piocher dans différentes feuilles Excel.
Pour cela j'utilise des signets. Tout cela fonctionne parfaitement mais j'aimerais que le texte extrait d'Excel pour être intégré à Word au niveau d'un signet garde sa mise en forme originale.
Je sais que .Text ne permet pas de garder la mise en forme mais je n'arrive pas à trouver la bonne propriété qui permettrais de copier la mise en forme sur Word.
Je précise que je souhaite exporter le texte sous format texte et pas sous format tableau.
Voici ma ligne de code :
wrdDoc.Bookmarks("Point32TO" & ColTO).Range.Text = Cells(2, 10) 'signet point 3.2
Je suis preneur de vos idées.
Merci pour votre lecture
Bonjour,
J'écrirai un truc du genre :
Dim Source As Range
Set Source = Sheets("Feuil1").Cells(2, 10)
With wrdDoc.Bookmarks("Point32TO" & ColTO).Range
.Text = Source.Value
.Font.Size = Source.Font.Size
.Font.Bold = Source.Font.Bold
.Font.Italic = Source.Font.Italic
.Font.Color = Source.Font.Color
' et autres réglages si besoin ...
End With
Pierre
Bonjour Pierre tout d'abord merci pour ta réponse.
Ma macro utilise une boucle et j'avoue que je ne sais pas vraiment comment l'adapter pour intégrer ta proposition...
Je pense que cette partie du code devrait te permettre de mieux comprendre la chose :
For ColTO = 9 To 12
NomTO = Table(j, ColTO)
For Each Feuille In ThisWorkbook.Worksheets
If NomTO = "" Then Exit For Else
If Feuille.Name = NomTO Then
Feuille.Activate
wrdDoc.Bookmarks("ObjectifTO" & ColTO).Range.Text = Cells(1, 11) 'Objectfif TO1
wrdDoc.Bookmarks("P31TO" & ColTO).Range.Text = Cells(4, 10) 'Nom TO
wrdDoc.Bookmarks("Point32TO" & ColTO).Range.Text = Cells(2, 10) 'signet point 3.2
wrdDoc.Bookmarks("TO" & ColTO).Range.Text = Cells(4, 10) 'Nom TO
wrdDoc.Bookmarks("P32TO" & ColTO).Range.Text = Cells(4, 10) 'Nom TO
wrdDoc.Bookmarks("Point60TO" & ColTO).Range.Text = Cells(5, 10) 'signet point 6 Preciser cahier d'enregistrement
wrdDoc.Bookmarks("Point6TO" & ColTO).Range.Text = Cells(6, 10) 'signet point 6 cahier d'enregistrement
wrdDoc.Bookmarks("Point61TO" & ColTO).Range.Text = Cells(7, 10) 'signet point 6.1 Engagement
wrdDoc.Bookmarks("Point610TO" & ColTO).Range.Text = Cells(7, 11) 'signet point 6.1 Preciser cahier des charges
wrdDoc.Bookmarks("Point62TO" & ColTO).Range.Text = Cells(6, 11) 'signet point 6.2 caractéristique de chargement
On Error GoTo Para
Range("Para" & NomTO).Select
Selection.Copy
wrdDoc.Bookmarks("Para" & ColTO).Range.PasteAndFormat (wdPasteOriginalFormatting)
Application.CutCopyMode = False
Para:
Err.Clear
Resume Ani
Ani: On Error Resume Next
Range("Ani" & NomTO).Select
If Err <> 0 Then Exit For
Selection.Copy
wrdDoc.Bookmarks("Ani" & ColTO).Range.PasteSpecial , _
DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine
Application.CutCopyMode = False
Exit For
End If
Next
ws.Activate
Next ColTO
Pierre, j'ai testé ta solution (je ne pensais avoir de temps dans l'instant mais finalement c'est bon).
Je l'ai testé juste pour la partie que tu m'as envoyé. Ca fonctionne très bien mais uniquement si le texte à un format unique.
Si quelques mots sont en gras ça bloque en indiquant "Erreur d'exécution 94 : Utilisation incorrecte de Null" ; idem pour la couleur. J'imagine que pour le reste c'est la même chose...
Et bien c'est pas dur.
En programmation quand on doit répéter la même opération plusieurs fois, il est mieux de factoriser dans une sous-procédure.
Dans le cas exposé, la manip "unitaire" qui est commune c'est copier le contenu d'une cellule xl et le coller avec son format dans le word.
Soit une sous-procédure du genre :
Sub Vers_signet(Sgnt As String, Source As Range)
With wrdDoc.Bookmarks(Sgnt).Range
.Text = Source.Value
.Font.Size = Source.Font.Size
.Font.Bold = Source.Font.Bold
.Font.Italic = Source.Font.Italic
.Font.Color = Source.Font.Color
' et autres réglages si besoin ...
End With
End Sub
- Q : Ben oui mais la variable wrdDoc va pas suivre?
- R : Il suffit de la déclarer Public au début du module
- Q : et comment utiliser cette sous-procédure?
- R : tout simplement, par exemple :
Vers_signet "ObjectifTO" & ColTO, Feuille.Cells(1, 11) 'Objectfif TO1
Et tu me vires vite-fait cet horrible Feuille.Activate
qui ne sert à rien
Merci pour tous ces retours !
Je ne connaissais pas les sous procédures, il faudra que je prenne le temps de me pencher dessus. En tout cas merci pour ces premiers éléments.
Ensuite, si je ne mets pas "Feuille.Activate" les signets ne se remplissent pas.
Enfin, j'ai essayé avec le On error resume next mais malheureusement ça ne fonctionne pas. Ca ne marche que si la totalité du contenu de la cellule est dans le même format. Sinon ça met le texte dans le format dans lequel est la ligne Word à laquelle il est inséré
Bonjour,
Voici une démo avec le code proposé qui fonctionne sur ma config. Une fenêtre de dialogue demande de pointer sur le doc (inclus dans le zip) qui contient 2 signet nommés "MEForme" et "Signet2" qui accueillent 2 infos de 2 feuilles différentes (sans horrible Activate)
Et voici le code :
Option Explicit
' ***********************************************************************
' ***** *****
' ***** CODE PierreP56 : http://tatiak.canalblog.com/ *****
' ***** *****
' ***********************************************************************
Public WordApp As Object, WordDoc As Object, Rng As Object
Sub Demo_Modif_Signet_Word()
Dim Ndf As String
Ndf = Word_A_Lire
If Fichier_IsOpen(Ndf) Then
Set WordApp = GetObject(, "Word.Application")
Set WordDoc = WordApp.Documents(Ndf)
Else
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(Ndf, ReadOnly:=False)
End If
WordApp.Visible = False
Vers_signet "MEForme", Sheets("Feuil1").Range("J2")
Vers_signet "Signet2", Sheets("Feuil2").Range("B5")
WordApp.Visible = True
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Sub Vers_signet(Sgnt As String, Source As Range)
On Error Resume Next
With WordDoc.Bookmarks(Sgnt).Range
.Text = Source.Value
.Font.Name = Source.Font.Name
.Font.Size = Source.Font.Size
.Font.Bold = Source.Font.Bold
.Font.Italic = Source.Font.Italic
.Font.Color = Source.Font.Color
.Font.Underline = Source.Font.Underline
' et autres réglages si besoin ...
End With
End Sub
Function Word_A_Lire() As String
ChDrive (Left(ActiveWorkbook.Path, 1))
ChDir ActiveWorkbook.Path
Word_A_Lire = Application.GetOpenFilename("Fichiers Word,*.doc;*.docx")
End Function
Function Fichier_IsOpen(ByRef ttk As String) As Boolean
On Error Resume Next
Open ttk For Input Lock Read As #1
Close #1
Fichier_IsOpen = (Err.Number <> 0)
End Function
Pierre