VBA按顺序粘贴多区域到Word文档时图片被覆盖问题求助

Sub Test_Pictures()

    Dim rng1 As Range, rng2 As Range
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("01")
    Set rng1 = ws.Range("Report01_1")
    Set rng2 = ws.Range("Report01_2")
    
    On Error Resume Next
    Set wordApp = GetObject(Class:="Word.Application")
    If wordApp Is Nothing Then
        Set wordApp = CreateObject(Class:="Word.Application")
    End If
    On Error GoTo 0
    
    wordApp.Visible = True
    Set wordDoc = wordApp.Documents.Add
    
    With wordDoc.Range
    
        rng1.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        wordDoc.Content.Paste
        wordDoc.Content.InsertParagraphAfter
    
        rng2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        wordDoc.Content.InsertAfter vbCr
        wordDoc.Content.Paste
    End With
    
End Sub

运行宏时，rng2对应的图片会覆盖rng1的图片，Word中仅显示rng2的图片，按下Ctrl+Z后才会显示rng1的图片，需解决覆盖问题。

问题核心是直接操作wordDoc.Content（代表整个文档内容的Range对象）时，调用Paste会替换该Range的全部内容，导致第二次粘贴覆盖第一次的结果。只需每次操作后将定位光标移到文档末尾，再进行后续粘贴即可。

修改后的代码方案一 #

Sub Test_Pictures()

    Dim rng1 As Range, rng2 As Range
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim ws As Worksheet
    Dim docRange As Object ' 跟踪当前操作位置
    
    Set ws = ThisWorkbook.Sheets("01")
    Set rng1 = ws.Range("Report01_1")
    Set rng2 = ws.Range("Report01_2")
    
    On Error Resume Next
    Set wordApp = GetObject(Class:="Word.Application")
    If wordApp Is Nothing Then
        Set wordApp = CreateObject(Class:="Word.Application")
    End If
    On Error GoTo 0
    
    wordApp.Visible = True
    Set wordDoc = wordApp.Documents.Add
    Set docRange = wordDoc.Content ' 初始化位置为文档开头
    
    ' 粘贴第一张图片并移到末尾
    rng1.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    docRange.Paste
    docRange.Collapse Direction:=2 ' 2对应wdCollapseEnd，将光标移到末尾
    docRange.InsertParagraphAfter
    docRange.Collapse Direction:=2
    
    ' 粘贴第二张图片并移到末尾
    rng2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    docRange.Paste
    docRange.Collapse Direction:=2
    docRange.InsertParagraphAfter
    
End Sub

修改后的代码方案二（简化写法） #

Sub Test_Pictures()

    Dim rng1 As Range, rng2 As Range
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("01")
    Set rng1 = ws.Range("Report01_1")
    Set rng2 = ws.Range("Report01_2")
    
    On Error Resume Next
    Set wordApp = GetObject(Class:="Word.Application")
    If wordApp Is Nothing Then
        Set wordApp = CreateObject(Class:="Word.Application")
    End If
    On Error GoTo 0
    
    wordApp.Visible = True
    Set wordDoc = wordApp.Documents.Add
    
    ' 粘贴第一张图片
    rng1.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    wordDoc.Range(wordDoc.Content.End - 1).Paste ' 定位到文档末尾前的位置粘贴
    wordDoc.Content.InsertParagraphAfter
    
    ' 粘贴第二张图片
    rng2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    wordDoc.Range(wordDoc.Content.End - 1).Paste
    wordDoc.Content.InsertParagraphAfter
    
End Sub

内容的提问来源于stack exchange，提问作者GetSmithed