Copying Charts and Data Ranges from Excel to Word when data present

I want to copy both Data Ranges and Charts from Excel to Word.

I found the below code. It doesn’t allow flexibility, in that not all charts and data ranges need to be copied as there may not be data present in some instances.

I assumed the code ran through all the data ranges first i.e., Column B and D before running through all the charts A to C.

I tried to amend the code in different ways to separate the copy paste of data ranges from charts component of the code so they ran separately. Rather than my attempted work around spaghetti code I am sharing the original code structure.

How can this code be amended to achieve the flexibility?

The code references a 'Summary' sheet column A-D showing the Sheet reference for the location of data ranges and charts and corresponding MS Word Bookmark references that the code uses to paste in Word. Columns A-D is populated by testing if data is present in each sheet and should only show the data ranges and charts that need to be copied.

Option Explicit

Sub ExportToWord()

Dim appWrd          As Object
Dim objDoc          As Object
Dim FilePath        As String
Dim FileName        As String
Dim x               As Long
Dim LastRow         As Long
Dim SheetChart      As String
Dim SheetRange      As String
Dim BookMarkChart   As String
Dim BookMarkRange   As String
Dim Prompt          As String
Dim Title           As String
Dim t               As Date 'for Timer
Dim Row1            As Long 'Find Last row in loop
Dim Col1            As Long 'Find Last column in loop

'set a variable equal to the starting time to calulate ellapsed time to run code
t = Now()
    
    'Turn some stuff off while the macro is running
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    'Assign the Word file path and name to variables
    FilePath = ThisWorkbook.Path
    FileName = "Test2.docx"
    
    'Determine the last row of data for our loop
    LastRow = Sheets("Summary").Range("A10").End(xlUp).Row
    
    'Create an instance of Word for us to use
    Set appWrd = CreateObject("Word.Application")
    
    'Open our specified Word file, On Error is used in case the file is not there
    On Error Resume Next
    Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
    On Error GoTo 0

    'If the file is not found, we need to end the sub and let the user know
    If objDoc Is Nothing Then
        MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
        appWrd.Quit
        Set appWrd = Nothing
        Exit Sub
    End If
    
    'Copy/Paste Loop starts`here
    For x = 2 To LastRow
        
        'Use the Status Bar to let the user know what the current progress is
        Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & "   (" & _
            Format((x - 1) / (LastRow - 1), "Percent") & ")"
        Application.StatusBar = Prompt
        
        'Assign the worksheet names and bookmark names to a variable
        'Use With to group these lines together
        With ThisWorkbook.Sheets("Summary")
            SheetChart = .Range("A" & x).Text
            SheetRange = .Range("B" & x).Text
            BookMarkChart = .Range("C" & x).Text
            BookMarkRange = .Range("D" & x).Text
        End With
           

        'Tell Word to goto the bookmark assigned to the variable BookMarkRange
         appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange

'*****************************Ignore Section of Original Code*****************************

        'Copy the data from Thisworkbook
        'ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
        
        'Paste into Word
        'appWrd.Selection.Paste
        
'****************Added Code Loop to find last Row and Column by Keywords**********************
             
 With ThisWorkbook.Sheets(SheetRange)
 
 ThisWorkbook.Sheets(SheetRange).Activate
 
            Col1 = .Cells.Find(What:="LastCol", _
            After:=Range("A1"), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Column
            
            
            Row1 = .Cells.Find(What:="LastRow", _
            After:=Range("A1"), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row
        
    
        'Copy the data from Thisworkbook
       .Range(Cells(2, 1), Cells(Row1 - 1, Col1)).Copy
        
        End With
        
        'Paste into Word
        appWrd.Selection.PasteSpecial xlPasteFormats
             
        'Clear Clipboard
        Application.CutCopyMode = False
        
'******************************Continue with original Code for Charts******************************

        'Tell Word to goto the bookmark assigned to the variable BookMarkChart
        appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
        
        'Copy the data from Thisworkbook
        ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
            
        'Paste into Word
        appWrd.Selection.Paste

    Next
     
    'Turn everything back on
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    
    'Let the user know the procedure is now complete
    'this code has been adapted from "www.VBAExpress.com"
    Prompt = "The procedure is now completed." & vbCrLf & vbCrLf & "Report" & vbCrLf & vbCrLf & "Ellapsed Time :" & Format(Now() - t, "hh:mm:ss")
    Title = "Procedure Completion"
    MsgBox Prompt, vbOKOnly + vbInformation, Title
    
    'Make our Word session visible
    appWrd.Visible = True
    
    'Clean up
    Set appWrd = Nothing
    Set objDoc = Nothing
   
End Sub

To determine where the code was falling over, I stripped the file back to dummy data and ran through the following scenarios.

Scenario 1 – Data is present for all charts and data ranges, Code works, No errors, All tables and charts come through as intended.

Scenario 2 – No data for Figure 5 and Table 3, these have been removed from the below list manually as opposed to a formula showing blank. Code works, no errors, Figure 5 and Table 3 did not come through as intended, however, Table 6 does not come through either, it appears the blank space for the Chart data in row 6 effects the code for the data range in row 6.

Scenario 3 – No data for Figure 2 and Table 5, these have been removed from the below list manually as opposed to a formula resulting in blank. Run time error occurs. Viewing the word document, Only Table 1 and Table 2 come in before the run time error appears.

Scenario 4 – No data for Figure 3 or Table 3, Using code/formulae in A-D to remove blanks.
A Run time errors occurs, Viewing the word document, all charts and tables come in except Figure 3 and Table 3 as intended before the run time error appears.
The issue seems to be that it recognises a formula in Row 7. I can resolve this by coding it, so that the data is pasted into A-D rather than having formula in the cell, however I still must contend with a Scenario 2 occurring.

You can try something like this (refactored a bit to split up the code into different methods, and removed the "extra" bits)

Sub ExportToWord()

    Dim objDoc As Object, LastRow As Long, rwInfo As Range
    Dim SheetChart As String, SheetRange As String, BookMarkChart As String, BookMarkRange  As String
    Dim Prompt As String, Title As String, wb As Workbook
    
    Set wb = ThisWorkbook
    Set objDoc = GetWordDoc(wb.Path & "\Test2.docx")
    If objDoc Is Nothing Then Exit Sub 'doc was not found
    
    objDoc.Application.Visible = True
    
    Set rwInfo = wb.Worksheets("Summary").Range("A2:D2") 'first row of settings
    
    Do While Application.CountA(rwInfo) > 0 'loop while have any data
        SheetChart = rwInfo.Cells(1).Value
        SheetRange = rwInfo.Cells(2).Value
        BookMarkChart = rwInfo.Cells(3).Value
        BookMarkRange = rwInfo.Cells(4).Value
        
        If Len(SheetChart) > 0 Then
            wb.Worksheets(SheetChart).ChartObjects(1).Copy
            objDoc.bookmarks(BookMarkChart).Range.Paste
        End If
        
        If Len(SheetRange) > 0 Then
            GetCopyRange(wb.Worksheets(SheetRange)).Copy
            objDoc.bookmarks(BookMarkRange).Range.PasteSpecial xlPasteFormats
        End If
        
        Set rwInfo = rwInfo.Offset(1) 'next row of settings
    Loop
        
End Sub

'open a Word document as return a reference to it
Function GetWordDoc(docPath As String) As Object
    Dim appWrd As Object, objDoc As Object
    Set appWrd = CreateObject("Word.Application")
    
    'Open the Word file, On Error is used in case the file is not there
    On Error Resume Next
    Set objDoc = appWrd.Documents.Open(docPath)
    On Error GoTo 0
    If objDoc Is Nothing Then 'alert user if not opened
        MsgBox "Unable to open the Word file:" & vbLf & docPath, _
               vbCritical, "File Not Found"
        appWrd.Quit
        Set appWrd = Nothing
        Exit Function
    End If
    Set GetWordDoc = objDoc
End Function

'given a data worksheet, find the range to copy
Function GetCopyRange(ws As Worksheet) As Range
    Dim col As Long, rw As Long
    col = ws.Cells.Find(What:="LastCol", After:=ws.Range("A1"), _
            LookAt:=xlPart, LookIn:=xlFormulas, _
            SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
            MatchCase:=False).Column
    rw = ws.Cells.Find(What:="LastRow", After:=Range("A1"), _
            LookAt:=xlPart, LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
            MatchCase:=False).Row
    Set GetCopyRange = ws.Range(ws.Cells(2, 1), ws.Cells(rw - 1, col))
End Function