从 Excel 到 Word 的自动复制粘贴有效，但没有源格式

Question

我在 Internet 上找到了一个代码，我已经适应了我自己使用的自动化复制粘贴。效果很好，只是当我将 Excel 图表粘贴到我的 Word 报告时，颜色会更改为目标主题。我需要保留源格式，并且由于报告是最终报告，我也无法更改配色方案。

由于某种原因Selection.PasteSpecial (wdChart) 不起作用，它被用作简单的粘贴。我有数百份报告要粘贴两打图表，请不要说我必须手动完成！请帮忙！

'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

Answer 1

我没有使用 Selection.PasteSpecial 方法，而是使用 Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

更改您的粘贴行

appWrd.Selection.PasteSpecial (wdChart)

到

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

不幸的是，MSDN 没有太多关于此的文档....希望它对你有用，没有太多麻烦

编辑

经过一番挖掘，我发现此方法的 idMso 参数对应于功能区控件 idMso。可以找到每个办公应用程序的完整列表，方法是转到文件 -> 选项 -> 自定义功能区，然后将鼠标悬停在列表中的每个命令上，工具提示将有一个描述，后跟一个用括号括起来的术语。括号中的此项是该命令的 idMso 字符串。

第二次编辑

下面是我如何从 Excel 到 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

DoEvents (MSDN) 的等待循环是因为这是在一个循环中粘贴十几个图表然后格式化它们。我在循环的下一部分（调整图表大小）中出错。但在这里我不得不 select 幻灯片并等待片刻，然后尝试粘贴以确保它在正确的幻灯片上。如果没有这个，它会粘贴到幻灯片 1 上。

这里没有任何东西让我觉得你遗漏了什么，但也许它会帮助你明白为什么它不起作用。

从 Excel 到 Word 的自动复制粘贴有效，但没有源格式

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

excel

vba

ms-word