VBA - Export Excel → Word

[Anthonymctm]

Bonjour à tous,

Pour plus de lisibilité, je créé ce topic avec les mises à jour qui s'imposent.

J'ai un fichier excel, d'une dizaine d'onglets, qui me sort au final 3 onglets utiles, synthétiques, mis en forme et qu'il faut que j'exporte sur Word.

J'ai regardé l'export avec liaison d'Excel sous Word et j'ai trouvé deux modes de collages plutôt pratiques : Avec liaison - Feuille de calcul Excel ou Avec liaison - Image en mode point.

En tout cas si j'utilise un des deux, que je réduis par les coins le tout pour que ça rentre en largeur ma feuille A4, ça donne quelque chose de plutôt correct et qui se modifie selon ce que je tape sur Excel.

Grace à Eric, je peux dorénavant générer les plages nommées comme mes sauts de page (ce qui me permet d'avoir une plage nommé par page Word) (https://www.excel-downloads.com/threads/creer-des-plages-nommees-dynamiques-format-a4.20034481/)

Donc maintenant il ne manque plus qu'à faire une extraction de ces plages nommées sur Word.

Pour ça je verrais bien un code du style
Ouvrir Word,
copier page 1 de la feuille En_tête,
coller sur Word en tant qu'image mode point, (largeur collage = large page Word, serait la cerise sur le gâteau )
si page_02 de en_tête existe, alors copier/coller image mode point à la page 2 du word
puis checker si page_03 existe etc,

sinon passer à l'onglet suivant,
copier page_01 de l'onglet Descriptif, puis coller sur Word à la page suivante
checker si page_02 de descriptif existe, etc

puis passer au dernier onglet Carac_tech
Et idem page_01 copier/coller sur word à la page suivant etc.

Sinon on peut aussi copier/coller sur word puis insérer un saut de page sur word, comme ça on est à la suivante

Si ça peut aider, le collage se fait comme ça

.PasteSpecial Link:=True, DataType:=wdPasteBitmap, Placement:= _
        wdInLine, DisplayAsIcon:=False

Mais c'est tout ce que je sais

Voilà, merci à tous, hésitez pas si je peux éclaircir quelques points

 

[Anthonymctm]

Juste pour mettre à jour, grâce à PierreJean et Eric du forum j'ai encore pu un peu avancé !

Voici le code actuel :

Function exist(feuille As String, nom As String) As Boolean
exist = False
On Error Resume Next
    x = Sheets(feuille).Range(nom).Address
    If Err.Number = 0 Then exist = True
On Error GoTo 0
End Function

Sub export_excel_to_word()

    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
    Dim MonInlineShape As Object 'Nouveau

    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add

' newObj.PageSetup.LeftMargin = CentimetersToPoints(1)
' newObj.PageSetup.RightMargin = CentimetersToPoints(1)
 
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
        Placement:=wdInLine, DisplayAsIcon:=False
        .TypeParagraph
        .InsertBreak Type:=7
        End With
Set MonInlineShape = newObj.inlineshapes(1) 'nouveau
    With MonInlineShape
         .LockAspectRatio = msoTrue
         .Width = 460.8
    End With
       
'Selection.InlineShapes(1).LockAspectRatio = msoTrue
'Selection.InlineShapes(1).Width = 498.9
    End If
Next

For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
       ' .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile,
        .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
        .TypeParagraph
        .InsertBreak Type:=7
        End With
    End If
Next

For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
        .TypeParagraph
        .InsertBreak Type:=7
        End With
    End If
Next
                   
   Application.CutCopyMode = False

    myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
    newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile

    MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"

    obj.Activate    'vous pouvez jouer sur les marges pour améliorer la lecture
    Set obj = Nothing
    Set newObj = Nothing
    Set MonInlineShape = Nothing

End Sub

J'ai les bons objets qui se collent au bon endroit, mais ils n'ont pas le bon format. (trop grand, il faut garder la proportion et diminuer la largeur)

J'ai ouvert un sujet dédié à ce réglage https://www.excel-downloads.com/thr...largeur-dun-objet-colle-issu-dexcel.20034800/

 

[Anthonymctm]

Si jamais ça peut aider quelqu'un, j'ai trouvé ma réponse :

-Je fais manuellement mes sauts de page

-Je lande la macro plagesNomees qui va reset les plages nommées et les refaire selon ma mise en page précédemment faite

-Je lande la macro export_excel_to_word qui va généré un fichier Word puis copier chacune des plages précédemment faite et va les coller les unes à la suite des autres en ajoutant un petit saut de page

Pour ce qui est du rendu et de la largeur, j'ai modifié manuellement sur excel les largeur des colonnes à exporter pour que leur largeur correspondent à la largeur d'une page A4.

Sub PlagesNommees()
    suppNomsPage "En_tête"
    nommerPages "En_tête"
    suppNomsPage "Descriptif"
    nommerPages "Descriptif"
    suppNomsPage "Carac_tech"
    nommerPages "Carac_tech"
End Sub
 
Sub nommerPages(nomF As String)
    Dim HPB As HPageBreak, numP As Long, nom As String
    Dim pl As Range, lig As Long, col1 As Long, nbCol As Long, derlig As Long
    ActiveWindow.View = xlPageBreakPreview
    With Sheets(nomF)
      On Error GoTo fin
        Set pl = Range(.PageSetup.PrintArea)
        On Error GoTo 0
        col1 = pl.Column: nbCol = pl.Columns.Count: derlig = pl.Row + pl.Rows.Count - 1
        lig = pl.Row
        For Each HPB In .HPageBreaks
            numP = numP + 1
            Set pl = .Cells(lig, col1).Resize(HPB.Location.Row - lig, nbCol)
            nom = nomF & "!page_" & Format(numP, "00")
            pl.Name = nom
            lig = HPB.Location.Row
        Next HPB
        If lig < derlig Then
            numP = numP + 1
            Set pl = .Cells(lig, col1).Resize(derlig - lig + 1, nbCol)
            nom = nomF & "!page_" & Format(numP, "00")
            pl.Name = nom
        End If
 
    End With
fin:
 
    Sheets("Descriptif").Select
    ActiveWindow.View = xlNormalView
    Sheets("Carac_tech").Select
    ActiveWindow.View = xlNormalView
    Sheets("En_tête").Select
    ActiveWindow.View = xlNormalView
 
End Sub
 
Sub suppNomsPage(nomF As String)
    Dim nom As Name
    For Each nom In ActiveWorkbook.Names
        If Left(nom.Name, Len(nomF) + 6) = nomF & "!page_" Then nom.Delete
    Next nom
End Sub
 
Function exist(feuille As String, nom As String) As Boolean
exist = False
On Error Resume Next
    x = Sheets(feuille).Range(nom).Address
    If Err.Number = 0 Then exist = True
On Error GoTo 0
End Function
 
Sub export_excel_to_word()
    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
 
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add
' obj.Selection.ParagraphFormat.LeftIndent = (20)
      With obj.Selection
        .PageSetup.TopMargin = (20)
        .PageSetup.LeftMargin = (17.5)
        .PageSetup.RightMargin = (20)
        .PageSetup.BottomMargin = (20)
    End With
 
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
     '   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
     End If
Next
 
For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
    End If
Next
 
For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
    End If
Next
 
   Application.CutCopyMode = False
    myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
    newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile
 
    MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
 
    obj.Activate    'vous pouvez jouer sur les marges pour améliorer la lecture
    Set obj = Nothing
    Set newObj = Nothing
End Sub

Voilà, c'était pas si compliqué