Macro for copying and pasting charts from Excel into Word

[behmenAL]

[FONT=&quot]I have two Excel workbooks. Each workbook has 55 charts in Sheet1. I want to paste these charts "as picture" in a Word doc. The following code works well for a small number of charts in one workbook. I’m looking for a way to adjust this code so it pastes charts from two workbooks in the following order: Chart1 from Workbook1 --> Chart1 from Workbook2 ---> Chart2 from Workbook1---> Chart2 from Workbook2 and so on.[/FONT]
[FONT=&quot]I'd like to adjust the code so I don't have to insert 110 bookmarks in Word and change each iteration of “copy chart/paste chart” to match the Bookmark name with Chart name. I’m thinking I can use an “Until loop” to select, copy and paste until Chart Name =”Chart 55” with a carriage return after each paste. Or, instead of bookmarks, just paste at Selection, TypeParagraph, then select, copy, and paste next chart until all are transferred. How do I specify there are two Excel workbooks to get charts from?

[FONT=&quot]Sub CopyCharts2Word()Dim wd As ObjectDim ObjDoc As ObjectDim FilePath As StringDim FileName As StringFilePath = "C:\Users\Name\Desktop"FileName = "Template.docx"'check if template document is open in Word, otherwise open itOn Error Resume NextSet wd = GetObject(, "Word.Application")If wd Is Nothing Then    Set wd = CreateObject("Word.Application")    Set ObjDoc = wd.Documents.Open(FilePath & "\" & FileName)Else    On Error GoTo notOpen    Set ObjDoc = wd.Documents(FileName)    GoTo OpenAlreadynotOpen:    Set ObjDoc = wd.Documents.Open(FilePath & "\" & FileName)End IfOpenAlready:On Error GoTo 0'find Bookmark in template docwd.Visible = TrueObjDoc.Bookmarks("Bookmark1").Select 'copy chart from Excel Sheets("Sheet1").ChartObjects("Chart1").Chart.ChartArea.Copy 'insert chart to Bookmark in template doc wd.Selection.PasteSpecial Link:=False, _ DataType:=wdPasteMetafilePicture, _ Placement:=wdInLine, _ DisplayAsIcon:=False'find Bookmark in template docwd.Visible = TrueObjDoc.Bookmarks("Bookmark2").Select 'copy chart from Excel Sheets("Sheet1").ChartObjects("Chart2").Chart.ChartArea.Copy 'insert chart to Bookmark in template doc wd.Selection.PasteSpecial Link:=False, _ DataType:=wdPasteMetafilePicture, _ Placement:=wdInLine, _ DisplayAsIcon:=False End Sub[/FONT][/FONT][/COLOR]

 

[John_w]

Welcome to MrExcel forums.

I can't read your code so started from scratch. For the code below, you need to set a reference to Microsoft Word Object Library, via Tools -> References in the Excel VBA editor. And edit the code to change the full file names of the Word document and the two workbooks. The charts are expected to be on "Sheet1" in both workbooks.

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:\folder\path\Word document.docx"  'CHANGE THIS
    
    Set wb1 = Workbooks.Open("C:\folder\path\Workbook1.xlsx", ReadOnly:=True)  'CHANGE THIS
    Set wb2 = Workbooks.Open("C:\folder\path\Workbook2.xlsx", ReadOnly:=True)  'CHANGE THIS
    
    '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

 

[behmenAL]

Hi John_w,
Thank you for taking the time to start from scratch! I know the code did not display correctly, but I can't find an option to edit my original post. I thought I put the right tags around the code. I will adjust your code and try it out next week.
Thanks again