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

Question

我在互联网上发现了一个代码，我已经适应了我自己的使用来自动复制粘贴。除了当我将Excel图表粘贴到单词报告时，颜色变为目标主题时效果很好。我需要保持源格式，因为报告是最终的，所以我也不能更改颜色方案。

由于某些原因，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没有在路上多关于这个的文档....希望它对你没有太大的作用麻烦

---

EDIT

一些挖我想出的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）环路是因为这是一个循环粘贴内十几个图表，然后格式化它们。我在循环的下一部分出现错误（调整图表大小）。但在这里，我必须选择silde并等待片刻，然后尝试粘贴以确保它位于正确的幻灯片上。如果没有它，它会粘贴在幻灯片1上。

这里没有任何内容会显示在我身上，因为您忽略了某些内容，但可能会帮助您了解为什么它不起作用。