Anthonymctm
XLDnaute Occasionnel
Bonjour à tous,
Après un dur labeur et grâce à votre aide je suis parvenu a faire une macro qui export mes données excel sous Word, j'ai récemment opté pour un copier coller en tant qu'image :
Pour remplacer l'ancien :
La macro s'exécute beaucoup plus rapidement, je n'ai plus les bugs liés aux liaisons et c'est bien plus facile de gérer des images.
En revanche la macro semble instable. Parfois elle fonctionne, parfois non. Je dirais que sur 10 exécutions, 6 fonctionnent.
Ça à l'air aléatoire, sans que je ne change rien au fichier (ou que je clique ailleurs)
Quand ça ne fonctionne pas c'est tantôt la ligne du .CopyPicture Appearance:=xlScreen, Format:=xlPicture qui est surlignée et parfois la ligne du .Paste
Vous trouverez un fichier exemple joint qui reproduit le même phénomène ainsi que le code en question ci dessous :
Après un dur labeur et grâce à votre aide je suis parvenu a faire une macro qui export mes données excel sous Word, j'ai récemment opté pour un copier coller en tant qu'image :
VB:
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.pastePour remplacer l'ancien :
Code:
.copy
.PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
Placement:=wdInLine, DisplayAsIcon:=FalseLa macro s'exécute beaucoup plus rapidement, je n'ai plus les bugs liés aux liaisons et c'est bien plus facile de gérer des images.
En revanche la macro semble instable. Parfois elle fonctionne, parfois non. Je dirais que sur 10 exécutions, 6 fonctionnent.
Ça à l'air aléatoire, sans que je ne change rien au fichier (ou que je clique ailleurs)
Quand ça ne fonctionne pas c'est tantôt la ligne du .CopyPicture Appearance:=xlScreen, Format:=xlPicture qui est surlignée et parfois la ligne du .Paste
Vous trouverez un fichier exemple joint qui reproduit le même phénomène ainsi que le code en question ci dessous :
VB:
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
Application.ScreenUpdating = False
Set obj = CreateObject("Word.Application")
obj.Visible = True
Set newObj = obj.Documents.Add
' obj.Selection.ParagraphFormat.LeftIndent = (20)
With obj.Selection.PageSetup
.TopMargin = (20)
.LeftMargin = (17.5)
.RightMargin = (20)
.BottomMargin = (0)
.HeaderDistance = (0)
.FooterDistance = (15)
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")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
With obj.Selection
.Paste
' .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")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
With obj.Selection
.Paste
.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")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
With obj.Selection
.Paste
.InsertBreak Type:=6
End With
End If
Next
newObj.Sections(1).Footers(1).PageNumbers.Add (2)
'obj.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
' PageNumberAlignment:=wdAlignPageNumberRight
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
Application.ScreenUpdating = True
MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
obj.Activate
Set obj = Nothing
Set newObj = Nothing
End Sub
Dernière édition: