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