VBA to copy from Excel as image and paste in Word

[JenDan]

I found some code that basically does what I need, but I need it to paste in as a picture. What needs to change for that? Thank you for any help!

Sub CopyWorksheetsToWord()
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
For Each ws In ActiveWorkbook.Worksheets
    Application.StatusBar = "Copying data from " & ws.Name & "..."
    ws.UsedRange.Copy
    wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
    wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
    Application.CutCopyMode = False
    wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
  If Not ws.Name = Worksheets(Worksheets.Count).Name Then
        With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
            .InsertParagraphBefore
            .Collapse Direction:=wdCollapseEnd
            .InsertBreak Type:=wdPageBreak
        End With
    End If
Next ws
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
With wdApp.ActiveWindow
    If .View.SplitSpecial = wdPaneNone Then
        .ActivePane.View.Type = wdNormalView
    Else
        .View.Type = wdNormalView
    End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
End Sub

 

[DanteAmor]

Change this:
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste

For this:
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.PasteAndFormat wdChartPicture

 

[JenDan]

Change this:
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste

For this:
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.PasteAndFormat wdChartPicture

I made the change and I get a blank Word document.

 

[DanteAmor]

That option works for me in Excel 2007. Maybe someone else can put another option.

 

[NdNoviceHlp]

This seems to work. HTH. Dave

Sub SaveXlRangeToWordFile()
Dim ObjPic As Object, Ws As Worksheet
Dim WdDoc As Object, WdApp As Object
'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If
'open doc **********change file path to suit
On Error GoTo erfix
Set WdDoc = WdApp.Documents.Open(Filename:="C:\yourfoldername\yourfilename.docx")
For Each Ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & Ws.Name & "..."
Ws.UsedRange.Copy
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9 '4
Application.CutCopyMode = False
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not Ws.Name = Worksheets(Worksheets.Count).Name Then
With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
End If
Next Ws

'pictures in newxl version are converted to inlineshapes
'takes time to paste and convert
'Application.Wait (Now + TimeValue("0:00:02"))
'For Each ObjPic In WdApp.ActiveDocument.InlineShapes
'ObjPic.ConvertToShape
'Next ObjPic
WdApp.ActiveDocument.Close savechanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.StatusBar = False
'Set ObjPic = Nothing
Exit Sub

erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close savechanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
Application.StatusBar = False
'Set ObjPic = Nothing
End Sub

 

[JenDan]

This seems to work. HTH. Dave

Sub SaveXlRangeToWordFile()
Dim ObjPic As Object, Ws As Worksheet
Dim WdDoc As Object, WdApp As Object
'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If
'open doc **********change file path to suit
On Error GoTo erfix
Set WdDoc = WdApp.Documents.Open(Filename:="C:\yourfoldername\yourfilename.docx")
For Each Ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & Ws.Name & "..."
Ws.UsedRange.Copy
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9 '4
Application.CutCopyMode = False
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not Ws.Name = Worksheets(Worksheets.Count).Name Then
With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
End If
Next Ws

'pictures in newxl version are converted to inlineshapes
'takes time to paste and convert
'Application.Wait (Now + TimeValue("0:00:02"))
'For Each ObjPic In WdApp.ActiveDocument.InlineShapes
'ObjPic.ConvertToShape
'Next ObjPic
WdApp.ActiveDocument.Close savechanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.StatusBar = False
'Set ObjPic = Nothing
Exit Sub

erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close savechanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
Application.StatusBar = False
'Set ObjPic = Nothing
End Sub

This is awesome! Thank you! Is there a way to keep it full size/full page? When I manually paste as picture, it fills the whole sheet (matching the size in Excel) but with this it's smaller. If not, at least this saves me way more time in the long run than I can even guess!

 

[Macropod]

Cross-posted at:

VBA to copy from Excel as image and paste in Word

I found some code that basically does what I need, but I need it to paste in as a picture. What needs to change in Excel 2016 for that? Thank you for any help! Sub CopyWorksheetsToWord() Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet Application.ScreenUpdating =...

www.excelforum.com

VBA to copy from Excel as image and paste in Word

I found some code that basically does what I need, but I need it to paste in as a picture. What needs to change in Excel 2016 for that? Thank you for any help! Sub CopyWorksheetsToWord() Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet Application.ScreenUpdating =...

www.vbaexpress.com

Please read Mr Excel's policy on Cross-Posting in rule 13: Message Board Rules