VBA Code to Copy and Paste Charts to Word

Hi, All.

I've recently found some VBA code online that I have amended to suit.

The code copies and pastes the charts from a worksheet into a Word document successfully.

With this code, all the charts in the worksheet are copied but I want to be able to select certain charts to be copied and pasted only.

I can name the charts in the worksheet Chart1, Chart2, Chart3, etc but I'm not sure how to amend the VBA code so only the charts I include in the code are copied and pasted.

Can anyone suggest where I need to amend the code so that specific charts are only copied?

The VBA code is:

Public Sub Copy_Charts_From_2_Workbooks_To_Word()

Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordRange As Word.Range
Dim WordDocumentFullName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim chObject As ChartObject
Dim i As Long, c1 As Long, c2 As Long

WordDocumentFullName = "C:\Chart Report.docx"

Set wb1 = Workbooks.Open("C\:Book1.xlsm", ReadOnly:=True)
Set wb2 = Workbooks.Open("C:\Book2.xlsm", ReadOnly:=True)

'Get existing instance of Word or create a new one

On Error Resume Next
Set WordApp = GetObject(Class:="Word.Application")
Err.Clear
If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")
If Err.Number = 429 Then
MsgBox "Microsoft Word is not installed.", vbCritical
Exit Sub
End If
On Error GoTo 0
WordApp.Visible = True

'Open Word document

Set WordDoc = WordApp.Documents.Open(Filename:=WordDocumentFullName, ReadOnly:=False)
Set WordRange = WordDoc.Range

c1 = 0
c2 = 0

For i = 1 To wb1.Worksheets("Sheet1").ChartObjects.Count + wb2.Worksheets("Sheet1").ChartObjects.Count

c1 = c1 + 1

If c1 <= wb1.Worksheets("Sheet1").ChartObjects.Count Then

Set chObject = wb1.Worksheets("Sheet1").ChartObjects(c1)
chObject.CopyPicture xlScreen, xlPicture

'Paste clipboard to Word document.
'Trap occasional Run-time error 4198: Method 'PasteSpecial' of object 'Range' failed

On Error Resume Next
Do
Err.Clear
WordRange.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
DoEvents
If Err.Number <> 0 Then Application.Wait DateAdd("s", 1, Now)
Loop While Err.Number <> 0
On Error GoTo 0

WordRange.SetRange WordRange.End, WordRange.End
WordRange.InsertParagraphAfter
WordRange.Collapse wdCollapseEnd

End If

c2 = c2 + 1

If c2 <= wb2.Worksheets("Sheet1").ChartObjects.Count Then

Set chObject = wb2.Worksheets("Sheet1").ChartObjects(c1)
chObject.CopyPicture xlScreen, xlPicture

'Paste clipboard to Word document.
'Trap occasional Run-time error 4198: Method 'PasteSpecial' of object 'Range' failed

On Error Resume Next
Do
Err.Clear
WordRange.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
DoEvents
If Err.Number <> 0 Then Application.Wait DateAdd("s", 1, Now)
Loop While Err.Number <> 0
On Error GoTo 0

WordRange.SetRange WordRange.End, WordRange.End
WordRange.InsertParagraphAfter
WordRange.Collapse wdCollapseEnd

End If

Next

MsgBox "Done"

End Sub

This would be a lot easier if you would upload a sample workbook. I did not build a workbook with charts to test this so it has not been tested or debugged, but I think this will work. I added a boolean variable. I also added 2 Select Case statements. 1 for each workbook, and and If Then for each workbook. All you need to do is change the names of the charts you want to copy (or add more Case lines to suit) in the Select Case statements. I commented the word "Added" for everything I added so you can do a search for that word if you want to see everything I added. You will have to name your charts to match the names in the Select Case statements. Here is the new code:

Please Login or Register  to view this content.