CODEWITHSUNDEEP
excelvbams-word
Tony
Tony

Reputation: 69

Auto copy-paste from Excel to Word works but no source formatting

I found a code on the Internet and I've adapted to my own use to automate copy-paste. Works great except that when I paste the Excel chart to my word report, the colors get changed to destination theme. I need to keep source formatting and as the report is final, I can't change the color scheme either.

For some reason Selection.PasteSpecial (wdChart) does not work, it's used as a simple paste. I've got hundreds of reports to paste two dozens of graphs to, please don't say I will have to do it manually! Help please!

'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 = "Trust03.docx"

'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

        BookMarkChart = .Range("C" & x).Text

    End With



    '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.PasteSpecial (wdChart)

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
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

Upvotes: 0

Views: 470

Answers (1)

Evan
Evan

Reputation: 608

Rather than using the Selection.PasteSpecial method I use Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

Change your paste line from

appWrd.Selection.PasteSpecial (wdChart)

to

appWrd.CommandBars.ExecuteMso ("PasteSourceFormatting")
appWrd.CommandBars.ReleaseFocus

Unfortunately MSDN doesn't have much in the way of documentation on this.... Hope it works for you without much trouble

EDIT

After some digging I figured out the the idMso parameter for this method corresponds to the ribbon controls idMso. A complete list of these can be found for each office application by going to File -> Options -> Customize Ribbon and then for each command hover over it in the list and the ToolTip will have a Description followed by a term enclosed in parentheses. This term in the parentheses is the idMso string for that command.

2nd EDIT

So here is how I do it from Excel to PowerPoint:

'Copy the object
    Wkst.ChartObjects("ChartName").Select
    Wkst.ChartObjects("ChartName").Copy
'Select Slide
    Set mySlide = myPresentation.Slides("SlideName")
    mySlide.Select
'stall to make sure the slide is selected
    For k = 1 To 1000
        DoEvents
    Next k
'paste on selected slide
    PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
    PPApp.CommandBars.ReleaseFocus
'sit and wait for changes to be made
    For k = 1 To 5000
        DoEvents
    Next k

The wait loops with DoEvents (MSDN) are because this is within a loop pasting a dozen or so charts and then formatting them. I got errors in the next part of the loop (resizing the chart). But here I had to select the silde and wait for a moment before attempting the paste to make sure it was on the right slide. Without this it pasted on slide 1.

Nothing here sticks out to me as something you're ommitting but maybe it will help you see why it is not working.

Upvotes: 1

Related Questions