从Excel自动复制粘贴到Word的作品，但没有源格式
我在互联网上find了一个代码，我已经适应了我自己的使用来自动复制粘贴。 除了当我粘贴Excel图表到我的单词报告，颜色更改为目标主题。 我需要保持源格式，因为报告是最终的，我也不能改变颜色scheme。
由于某些原因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 而不是使用Selection.PasteSpecial方法，我使用Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
改变你的粘贴线
appWrd.Selection.PasteSpecial (wdChart)
至
appWrd.CommandBars.ExecuteMso ("PasteSourceFormatting") appWrd.CommandBars.ReleaseFocus
不幸的是，MSDN在这方面的文档没有太多….希望它适合你没有太多的麻烦
编辑
经过一番挖掘，我想出了这个方法的idMso参数对应于function区控件idMso。 通过转到文件 – >选项 – >自定义function区，然后将每个命令hover在列表中，并且工具提示将具有一个描述，后面跟着一个用圆括号括起来的术语，可以find每个办公应用程序的完整列表。 括号中的这个术语是该命令的idMsostring。
第二编辑
所以这里是我如何从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 ）的等待循环是因为这是在循环内粘贴十几个图表，然后格式化它们。 我在循环的下一部分出现了错误（调整图表的大小）。 但在这里，我必须selectsilde并等待片刻，然后尝试粘贴，以确保它在右侧的幻灯片上。 没有这个，它粘贴在幻灯片1上。
这里没有任何东西可以作为你正在省略的东西，但也许会帮助你明白为什么它不起作用。