拷贝多个Excel单元格区域为图片并粘贴到Word

Excel工作表Sheet1中有两个报表，相应单元格区域分别定义名称为Report1和Report2，如下图所示。

现在需要将图片拷贝图片粘贴到新建的Word文档中。

示例代码如下。

Sub Demo()Dim oWordApp As ObjectDim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")Dim rRpt1 As Range: Set rRpt1 = ws.Range("Report1")Dim rRpt2 As Range: Set rRpt2 = ws.Range("Report2")On Error Resume NextSet oWordApp = GetObject(Class:="Word.Application")If oWordApp Is Nothing ThenSet oWordApp = CreateObject(Class:="Word.Application")End IfOn Error GoTo 0oWordApp.Visible = TrueDim oDoc As Object: Set oDoc = oWordApp.Documents.AddrRpt1.CopyPicture Appearance:=xlScreen, Format:=xlPictureoDoc.Content.PasteoDoc.Content.InsertParagraphAfterrRpt2.CopyPicture Appearance:=xlScreen, Format:=xlPictureoDoc.Content.InsertParagraphAfteroDoc.Content.Paste' oDoc.SaveAs2 "C:\temp\report.docx"' oDoc.Close' oWordApp.Quit
End Sub

【代码解析】
第3行代码获取工作表对象。
第4~5行代码获取单元格区域Range对象。
第6~11行代码获取Word应用程序对象，如果没有打开的Word应用程序，那么将新建一个。
第12行代码显示Word应用程序（新建的Word应用程序处于隐藏状态）。
第13行代码新建Word文档。
第14行代码将报表1拷贝为图片。
第15行代码在Word文档中粘贴图片。
第16行代码插入段落分隔符。
第17~19行代码使用类似的方法处理报表2。
第20行代码保存新建的Word文档。
第21行代码关闭Word文档。
第22行代码关闭Word应用程序。

运行代码，新建Word文档如下所示，只有报告2，并没有报告1。

使用单步调试运行代码，发现第15行代码执行之后，Word文档中插入了报表1，但是第19行代码（oDoc.Content.Paste）执行时将文档全部内容替换为报表2，因此报表1从此消失。

找到了问题的根源，那么可以使用如下两个方案解决问题。

    ' 方法1With oDoc.ContentrRpt1.CopyPicture Appearance:=xlScreen, Format:=xlPicture.Paste.InsertParagraphAfterrRpt2.CopyPicture Appearance:=xlScreen, Format:=xlPicture.Characters.Last.PasteEnd With

【代码解析】
oDoc.Content.Characters.Last获取文档中的最后一个字符，报表2图片将粘贴在此位置，避免覆盖已有的文档内容。

    ' 方法2With oDoc.ContentrRpt1.CopyPicture Appearance:=xlScreen, Format:=xlPicture.Paste.InsertParagraphAfteroWordApp.Selection.endKey Unit:=6rRpt2.CopyPicture Appearance:=xlScreen, Format:=xlPictureoWordApp.Selection.PasteEnd With

【代码解析】
第5行代码将Word编辑游标定位到文档末尾，第7行代码使用Selection.Paste粘贴报表2。

运行修改的代码，结果如下图所示。