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:
