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
| Private Sub CommandButton1_Click()
Dim WdApp As Word.Application
Dim WdDoc As Word.Document
Dim i, hauteur As Double, plage As Range
Dim j As Integer
Dim k As Integer
Dim nbre As Integer
Set WdApp = CreateObject("word.application")
Set WdDoc = WdApp.Documents.Open("C:\ah.doc")
WdApp.Visible = True
nbre = ActiveWorkbook.Sheets.Count
For j = 2 To 11
If Worksheets(j).Range(J25) <> 0 Or Worksheets(j).Range(J26) <> 0 Then
Do 'Sélection de la plage de cellules à copier
On Error Resume Next 'gère une plage nulle
Set plage = Range("A1:L38")
If plage Is Nothing Then GoTo Fin 'sortie si plage vide
On Error GoTo 0
Loop While InStr(plage.Address, ",") <> 0
plage.Copy 'plage copiée
DoEvents 'laisse au system le temps de copier la plage
'Place l'image sur le signet "Signet"
With WdApp
.Selection.Goto What:=wdGoToBookmark, Name:="Signet"
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, _
Placement:=wdInLine, DisplayAsIcon:=False
WdDoc.InlineShapes(1).Width = 132 'Règle la largeur dans Word
'Calcul de la hauteur de plage dans le document word
hauteur = 132 / WdDoc.InlineShapes(1).Width _
* WdDoc.InlineShapes(1).Height
WdDoc.InlineShapes(1).Height = Int(hauteur) 'Règle la hauteur
End With
End If
Next j
If nbre > 15 Then
For k = 16 To nbre
If Worksheets(k).Range(J25) <> 0 Or Worksheets(k).Range(J26) <> 0 Then
Do 'Sélection de la plage de cellules à copier
On Error Resume Next 'gère une plage nulle
Set plage = Range("A1:L38")
If plage Is Nothing Then GoTo Fin 'sortie si plage vide
On Error GoTo 0
Loop While InStr(plage.Address, ",") <> 0
plage.Copy 'plage copiée
DoEvents 'laisse au system le temps de copier la plage
'Place l'image sur le signet "Signet"
With WdApp
.Selection.Goto What:=wdGoToBookmark, Name:="Signet"
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, _
Placement:=wdInLine, DisplayAsIcon:=False
WdDoc.InlineShapes(1).Width = 132 'Règle la largeur dans Word
'Calcul de la hauteur de plage dans le document word
hauteur = 132 / WdDoc.InlineShapes(1).Width _
* WdDoc.InlineShapes(1).Height
WdDoc.InlineShapes(1).Height = Int(hauteur) 'Règle la hauteur
End With
End If
Next k
End If
'WdApp.Visible = True 'Pour voir (Ne pas fermer le fichier depuis Word)
Fin::
WdDoc.Close True 'Enregistre et ferme le doc word
DoEvents 'Laisse au system le temps d'enregistrer le fichier
WdApp.Quit 'ferme la session
Set plage = Nothing
Set WdApp = Nothing
Set WdDoc = Nothing
End Sub |
