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

x--ben a écrit :

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...

Il suffit d'ajouter un on error resume next au début de la sous-procédure

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