vba代码将多个excel图表复制到word
我使用VBA代码here将excel工作簿中的所有图表和表格从模板中复制到新的word文档中,该模板使用书签进行了预格式化(标记为Book1,Book2等等)。不幸的是我只有几桌,但大约20图表,如果我留一个空白汇总表的范围内我得到vba代码将多个excel图表复制到word
运行时错误“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
有多个问题与此代码,其中包括一个事实,即如果你有超过图表的详细范围也只是尽可能多的范围,因为是复制图表。
但快速解决您的问题,更换
'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
感谢@GSerg的帮助和格式编辑 - 它现在崩溃在'从本工作簿复制数据 ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy with runtime error 9 - 下标超出范围。 – 2012-07-18 15:16:24
@j_hindsight这将意味着您为图表设置书签名称,但未提供图表的名称(或拼写错误)。 – GSerg 2012-07-18 22:20:30
是的!其中一个书签正在玩弄。感谢您的所有帮助 - 意味着我实际上可以完成一些工作,而不是整天复制和粘贴;-) – 2012-07-19 07:47:25
这不会解决你的主要问题,但我会用这个来找到最后一排,而不是当前的代码提醒: LastRow = Sheets(“Summary”)。范围(“A”和Rows.Count).End(xlUp).Row'自65536不是新版本的Excel中的最后一行。 – 2012-07-18 14:44:27
谢谢我将它添加到代码 – 2012-07-18 15:18:24