Mise en page/export Excel sur Word

• Tableurs = Calculs, graphiques, opérations complexes, tris et filtres ...
• Traitements de texte = Documents rédigés (lettres, rapports, fiches, mémoires, tableaux, formulaires) ...
• Bases de données = Classements, listes, requêtes, rapports ...
• Gestion d'image = Création/modification de dessins, peinture, croquis, plans 2D-3D
• Traitement de photos = Retouches, transformations, recoloration, arrière-plans ... etc.

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

Sub test()
    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:
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
 
 ' 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
             ' .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
       ' Placement:=wdInLine, DisplayAsIcon:=False
        .TypeParagraph
        .InsertBreak Type:=7
        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:=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
 
End Sub