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没有太多关于此问题的文档....希望它对您有用而没有太多麻烦

修改

经过一番挖掘，我发现这个方法的idMso参数对应于功能区控件idMso。通过转到文件 - ＆gt;可以找到每个办公应用程序的完整列表。选项 - ＆gt;自定义功能区，然后将每个命令悬停在列表中，并且工具提示将有一个描述，后跟括在括号中的术语。括号中的这个术语是该命令的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上。

这里没有任何东西可以帮助你，因为它可能会帮助你了解它为什么不起作用。

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

1 个答案: