VBA代碼將多個Excel圖表復制到Word

Question

我在這里使用VBA代碼將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