Hi,
for a report that has to get updates on a montly basis, I try to write a macro that would update all charts and tables in it automatically.
My approach is to bookmark every table and every chart and to export the list of bookmarks to Excel (macro for this works well). I then add, for each bookmark, the path to the file where the relevant table/chart is located, the corresponding worksheet as well as the chart name (or table range).
Let's only discuss the charts here. The macro I am currently working on would read this reference file, grab the charts in the right file and replace them at the bookmark location in word.
I am at a point where it works, here is the code:
Code:
Sub UpdateWordFromExcelMappings()
Dim xlApp As Object
Dim xlRefWB As Object
Dim xlDataWB As Object
Dim xlSheet As Object
Dim chartObj As Object
Dim chartImg As Object
Dim i As Long, lastRow As Long
Dim wordBookmark As String
Dim filePath As String, sheetName As String, rangeOrChart As String
Dim bmRange As Range
' Reference file and worksheet names
Const REF_FILE_PATH As String = "\\Path\to\the\reference\file.xlsx"
Const TABLE_SHEET As String = "Tables"
Const CHART_SHEET As String = "Graphs"
' Start Excel
Set xlApp = CreateObject("Excel.Application")
Set xlRefWB = xlApp.Workbooks.Open(REF_FILE_PATH, False, True)
' === Handle Charts ===
With xlRefWB.Sheets(CHART_SHEET)
lastRow = .Cells(.Rows.Count, 1).End(xlUp).row ' Find last used row in column A
For i = 2 To lastRow
' Read and trim values from reference file
wordBookmark = Trim(CStr(.Cells(i, 1).Text))
filePath = Trim(CStr(.Cells(i, 5).Text))
sheetName = Trim(CStr(.Cells(i, 6).Text))
rangeOrChart = Trim(CStr(.Cells(i, 7).Text))
' Skip row if required info is missing
If wordBookmark = "" Or filePath = "" Or sheetName = "" Or rangeOrChart = "" Then
Debug.Print "Skipping chart row " & i & " due to missing data"
Else
' Open chart source workbook (or reuse the reference file if same)
If xlRefWB.FullName = filePath Then
Set xlDataWB = xlRefWB
Else
If Not WorkbookIsOpen(filePath) Then
Set xlDataWB = xlApp.Workbooks.Open(filePath, False, True)
Else
Set xlDataWB = xlApp.Workbooks(filePath)
End If
End If
' Try to get the worksheet
Set xlSheet = xlDataWB.Sheets(sheetName)
' Try to get the chart object
Set chartObj = Nothing
On Error Resume Next
Set chartObj = xlSheet.ChartObjects(rangeOrChart)
On Error GoTo 0
If Not chartObj Is Nothing Then
' Copy the chart as an image
chartObj.CopyPicture Appearance:=1, Format:=2 ' xlScreen, xlPicture
' Paste into Word if bookmark exists
If ActiveDocument.Bookmarks.Exists(wordBookmark) Then
Set bmRange = ActiveDocument.Bookmarks(wordBookmark).Range
bmRange.Paste
ActiveDocument.Bookmarks.Add wordBookmark, bmRange ' Re-add the bookmark after paste
End If
Else
MsgBox "Chart '" & rangeOrChart & "' not found in sheet '" & sheetName & "'", vbExclamation
End If
' Only close the workbook if it's not the reference file
If Not xlDataWB Is xlRefWB Then xlDataWB.Close False
End If
Next i
End With
' Cleanup
xlRefWB.Close False
xlApp.Quit
Set xlApp = Nothing
MsgBox "Tables and charts have been updated.", vbInformation
End Sub
Function WorkbookIsOpen(filePath As String) As Boolean
Dim wb As Workbook
On Error Resume Next ' In case of error (e.g., workbook not found)
Set wb = xlApp.Workbooks(filePath) ' Try to get the workbook
On Error GoTo 0 ' Reset error handling
If Not wb Is Nothing Then
WorkbookIsOpen = True ' Workbook is open
Else
WorkbookIsOpen = False ' Workbook is not open
End If
End Function
The only thing bothering me is that the charts are copied as pictures, and I would like to have editable objects (but not necessarily linked to the source file). I tried to use
instead of
Code:
chartObj.CopyPicture
but this throws runtime error 445.
Any idea how to solve this?
Thank you!
(code parts about tables removed here, that's another topic...)