VBA Code to Copy and Paste Charts to Word

[cosmica67]

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