vba代码将多个excel图表复制到word

Question

我使用VBA代码here将excel工作簿中的所有图表和表格从模板中复制到新的word文档中，该模板使用书签进行了预格式化（标记为Book1，Book2等等）。不幸的是我只有几桌，但大约20图表，如果我留一个空白汇总表的范围内我得到

运行时错误“5101”：
应用程序定义或对象定义的错误

它只能在间隙之前复制和粘贴图表和表格。

这是我的Excel汇总表：

任何想法如何，我可以修改代码以防止这种情况？

对不起 - 我是一个完整的VBA小白

'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 = "WorkWithExcel.doc" 

    '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 
      SheetRange = .Range("B" & x).Text 
      BookMarkChart = .Range("C" & x).Text 
      BookMarkRange = .Range("D" & x).Text 
     End With 

     'Tell Word to goto the bookmark assigned to the variable BookMarkRange 
     appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange 

     'Copy the data from Thisworkbook 
     ThisWorkbook.Sheets(SheetRange).UsedRange.Copy 

     'Paste into Word 
     appWrd.Selection.Paste 

     '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.Paste 
    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 & "www.VBAExpress.com" 
    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 

完整的工作代码如下。我修改了代码，以便将图表粘贴为元文件，因为这是我的老板所需要的。

'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 = "WorkWithExcel.doc" 

    'Determine the last row of data for our loop 
    LastRow = Sheets("Summary").Range("A" & Rows.Count).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 
      SheetRange = .Range("B" & x).Text 
      BookMarkChart = .Range("C" & x).Text 
      BookMarkRange = .Range("D" & x).Text 
     End With 

If Len(BookMarkRange) > 0 Then 

'Tell Word to goto the bookmark assigned to the variable BookMarkRange 
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange 

'Copy the data from Thisworkbook 
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy 

'Paste into Word 
appWrd.Selection.Paste 
End If 

If Len(BookMarkChart) > 0 Then 

'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 ppPasteEnhancedMetafile 
appWrd.Selection.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _ 
     Placement:=wdInLine, DisplayAsIcon:=False 

End If 

    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 & "www.VBAExpress.com" 
    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

有多个问题与此代码，其中包括一个事实，即如果你有超过图表的详细范围也只是尽可能多的范围，因为是复制图表。

但快速解决您的问题，更换

'Tell Word to goto the bookmark assigned to the variable BookMarkRange 
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange 

'Copy the data from Thisworkbook 
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy 

'Paste into Word 
appWrd.Selection.Paste 

'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.Paste 

与

if len (BookMarkRange) > 0 then 
    'Tell Word to goto the bookmark assigned to the variable BookMarkRange 
    appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange 

    'Copy the data from Thisworkbook 
    ThisWorkbook.Sheets(SheetRange).UsedRange.Copy 

    'Paste into Word 
    appWrd.Selection.Paste 
end if 

if len(BookMarkChart) > 0 then 
    '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.Paste 
end if