Excel VBA宏导出图表至Word问题：图片重叠且需居中

需要通过Excel VBA宏将Excel文件中所有图表以图片形式依次导出到Word文档，每张图表紧随上一张之后，但目前所有图片都粘贴在上一张上方，仅显示最后一张。同时希望实现图片居中显示。

原VBA代码 #

Sub ExportChartsToWord()
    ' Declare variables
    Dim WdApp As Object
    Dim WdDoc As Object
    Dim Ws As Worksheet
    Dim chrt As ChartObject
    Dim chrtName As String
    Dim i As Integer

    ' Initialize Word application
    Set WdApp = CreateObject("Word.Application")
    WdApp.Visible = True
    Set WdDoc = WdApp.Documents.Add
    
    File = "E:\Documents - Misc\Charts to Word.docx"
    'Word session creation
   
    'word will be closed while running
   ' WordApp.Visible = False
    'open the .doc file
    Set WdDoc = WdApp.Documents.Open(File)
 
    'Loop through each worksheet
    For Each Ws In ThisWorkbook.Worksheets
        
    'Loop through each chart in the worksheet
        For Each chrt In Ws.ChartObjects
            ' Copy the chart
            chrt.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
            ' Paste the chart into Word
            WdDoc.Content.InsertAfter ""
            'Selection.TypeParagraph
            'Selection.MoveDown Unit:=wdLine, Count:=3
            WdDoc.Content.PasteAndFormat (wdFormatOriginalFormatting)
            WdDoc.Content.ParagraphFormat.Alignment = wdAlignParagraphCenter
            WdDoc.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            'WdDoc.Content.Alignment = wdAlignCenter
            'Selection.TypeParagraph

            'Add a new page after each chart
            WdDoc.Content.InsertParagraphAfter
            WdDoc.Content.ParagraphFormat.SpaceAfter = 6
            WdDoc.Content.ParagraphFormat.SpaceBeforeAuto = True
            ' Loop through all inline shapes (images) in the document

           'wdDoc.Content.MoveDown
           'wdDoc.Selection.MoveDown Unit:=wdLine, Count:=2
           'wdDoc.Content.TypeParagraph
           'wdDoc.Selection.Find.Execute Replace:=2
           'wdDoc.Selection.Expand wdParagraph
           'wdDoc.Selection.InlineShapes(1).Select
           'wdDoc.Selection.InsertParagraphAfter
        Next chrt
    Next Ws
 
    ' Save the Word document
    WdDoc.SaveAs2 "E:\Documents - Misc\Charts to Word.docx"
 
    ' Clean up
    'wdDoc.Close
    'wdApp.Quit
    'Set wdDoc = Nothing
    'Set wdApp = Nothing
 
    MsgBox "Charts exported successfully!"
End Sub

问题分析与修改后的代码 #

原代码核心问题是每次粘贴时直接操作WdDoc.Content（整个文档内容），导致新图片叠加在已有内容上方。以下是修复后的代码，同时实现图片居中显示：

Sub ExportChartsToWord()
    Dim WdApp As Object
    Dim WdDoc As Object
    Dim Ws As Worksheet
    Dim chrt As ChartObject
    Dim targetRange As Object ' 定位插入位置
    Dim inlineShape As Object

    ' 初始化Word应用
    Set WdApp = CreateObject("Word.Application")
    WdApp.Visible = True
    
    ' 打开指定Word文档
    Dim filePath As String
    filePath = "E:\Documents - Misc\Charts to Word.docx"
    Set WdDoc = WdApp.Documents.Open(filePath)
 
    ' 遍历所有工作表
    For Each Ws In ThisWorkbook.Worksheets
        ' 遍历工作表中的所有图表
        For Each chrt In Ws.ChartObjects
            ' 复制图表为图片
            chrt.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
            ' 将插入点定位到文档末尾
            Set targetRange = WdDoc.Range(WdDoc.Content.End - 1, WdDoc.Content.End - 1)
            ' 粘贴图片
            targetRange.PasteAndFormat wdFormatOriginalFormatting
            
            ' 获取刚粘贴的图片，设置所在段落居中
            Set inlineShape = WdDoc.InlineShapes(WdDoc.InlineShapes.Count)
            inlineShape.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            
            ' 在图表后添加段落分隔
            WdDoc.Range(WdDoc.Content.End - 1).InsertParagraphAfter
        Next chrt
    Next Ws
 
    ' 保存文档
    WdDoc.SaveAs2 filePath
 
    ' 清理对象
    Set inlineShape = Nothing
    Set targetRange = Nothing
    Set WdDoc = Nothing
    Set WdApp = Nothing
 
    MsgBox "图表导出成功！"
End Sub

关键修改说明 #

• 定位插入点：通过WdDoc.Range(WdDoc.Content.End - 1, WdDoc.Content.End - 1)将光标移到文档末尾，确保新图片粘贴在最后，不会覆盖已有内容。
• 图片居中：获取刚粘贴的内嵌图片，对其所在段落设置居中对齐，实现图片居中显示。
• 添加段落分隔：在每张图表后插入新段落，避免图片之间无间距紧贴。

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