Pushing Charts and Ranges from Excel to Word

So I have a report with over a hundred charts and ranges that come from an Excel file. The problem is, that all the linking is very heavy on my Word doc and, in fact, not all the links update properly when I open the Word doc.

I figure the best way around this is to PUSH these to Word, at bookmark locations as pictures instead.

Can someone help?

This question was posted elsewhere and for someone else. But I have seen it done and think it ought to be added to our KB. I have also informed the original questioner that I was going to post it.

THANKS!!

Out of curiosity, why are we using Word. Why can't the report be made in Excel?

1. Too much other text.
2. Need different odd/even page headers.

ok.

So what are the real names of the sheets in Excel. Or are the really named as they are here. Would making a summary sheet in Excel with all the sheet names in nice column be an option?

I am going to say yes. Here's the guy's actual Q:

Quote:

---

I have created a word document that contains many links from a dynamically populated excel workbook. It contains graphs and information in cells.

I think I have reached a SECRET limit of linked items in the word document because it occasionally does not update some of the links. When I fix a link, it either corrupts itself, or allows a fix, but results in another SNEAKY link failing elsewhere.

Please can someone help me with methods and solutions.

The document is 73 pages long, with 900 links and 102 graphs. It is nicely formatted with odd and even pages and background images, hence the choice of applications.

---

How much do you love me?

Check this out.

Make sure to set a reference to MS Word Object Library.

[VBA]
Option Explicit

Private 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

FilePath = ThisWorkbook.Path
FileName = "WorkWithExcel.doc"
LastRow = Sheets("Summary").Range("A65536").End(xlUp).Row
Set appWrd = CreateObject("Word.Application")
appWrd.Visible = True
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error GoTo 0
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
For x = 2 To LastRow
SheetChart = ThisWorkbook.Sheets("Summary").Range("A" & x).Text
SheetRange = ThisWorkbook.Sheets("Summary").Range("B" & x).Text
BookMarkChart = ThisWorkbook.Sheets("Summary").Range("C" & x).Text
BookMarkRange = ThisWorkbook.Sheets("Summary").Range("D" & x).Text

appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
appWrd.Selection.Paste
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
appWrd.Selection.Paste
Next

End Sub

[/VBA]

Let me COUNT THE WAYS!!
Okay. I'm gonna alert this guy...

And add a msgbox in the end so the user know when the process is finish as well ;)

BTW, add also some With-statement and after that DB may send You some flowers ;)

Kind regards,
Dennis

Don't forget to cleanup ...

Set appWrd = Nothing
Set objDoc = Nothing

Nice one Jake! :yes

Ok, I added a bit to make you all happy. :)

[VBA]
'You must set a reference to Microsoft Word Object Library from Tools | References

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

'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 = "WorkWithExcel.doc"

'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A65536").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

'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy

'Paste into Word
appWrd.Selection.Paste

'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
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf & "www.VBAExpress.com"
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

[/VBA]

Jake, can you please add this to the KB.
This is TOO cool. :)

Ok, its added. Can you review/approve it?

User can't get it to work and neither can I.
What are we doing wrong?

Sorry. To clarify: It pastes the same large area of the worksheet at EVERY bookmark.

The way you have it setup now is not the way it was originally, so there is your problem. :whip :) It started with the charts on one sheet and the range on the other, but now with them both combined all on one sheet.

We can still work with this, but I really need to know how the data is actually layed out in Excel.

Ok, I made some changes. The user will need to specify the sheet and the range address or chart name as well as the corrosponding bookmark. It seems to work fine. In the attachment, the bookmarks are not setup well in Word so the chart overlaps the data, but the chart is at the correct bookmark.


[vba]

'You must set a reference to Microsoft Word Object Library from Tools | References

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 SheetName As String
Dim BookMarkName As String
Dim Prompt As String
Dim Title As String
Dim ChartName As String
Dim RangeAddress As String

'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 = "report1.doc" '"WorkWithExcel.doc"

'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A65536").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 Charts)
For x = 2 To LastRow

'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Charts: " & 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")
SheetName = .Range("A" & x).Text
BookMarkName = .Range("B" & x).Text
ChartName = .Range("C" & x).Text
End With

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

'Copy the Chart from Thisworkbook
ThisWorkbook.Sheets(SheetName).ChartObjects(ChartName).Copy

'Paste into Word
appWrd.Selection.Paste

Next

LastRow = Sheets("Summary").Range("D65536").End(xlUp).Row

'Copy/Paste Loop starts here (For Data)
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")
SheetName = .Range("D" & x).Text
BookMarkName = .Range("E" & x).Text
RangeAddress = .Range("F" & x).Text
End With

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

'Copy the Chart from Thisworkbook
ThisWorkbook.Sheets(SheetName).Range(RangeAddress).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
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf & "www.VBAExpress.com"
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

[/vba]