循环将Excel散点平滑图表复制到Word时避免覆盖问题求助

问题根源 #

1. 图表引用关联：直接修改并复用同一个Excel图表模板，Word中粘贴的元文件图片会关联原图表，当原图表数据更新时，所有已粘贴的图片都会同步变化，最终全部显示为最后一次的图表内容。
2. 粘贴位置错误：wDoc.Range.PasteSpecial默认指向文档起始范围，每次粘贴会插入到开头，导致视觉上的“替换”效果。
3. 变量声明不规范：部分变量未明确类型，可能引发隐式类型转换问题。

修复方案 #

关键改动点 #

• 创建临时图表副本：复制模板图表为临时对象，修改临时图表的数据后再复制图片，最后删除临时图表，彻底切断图片与原模板的关联。
• 定位粘贴到文档末尾：使用wDoc.Content.End指定粘贴位置，确保图片按顺序追加到文档最后。
• 优化分页逻辑：直接插入分页符替代复杂的选区跳转，代码更简洁可靠。
• 规范变量声明：明确所有变量类型，避免隐式错误。

修改后的完整代码 #

Sub create_Graph()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim searchRange As Range, match As Range
    Dim firstMatch As String
    Dim currentValue As Variant
    Dim currentRow As Long
    Dim lastRow1 As Long, lastRow2 As Long
    Dim startRow1 As Long, startRow2 As Long
    Dim endRow1 As Long, endRow2 As Long
    Dim tempChartObj As ChartObject
    Dim wApp As Object
    Dim wDoc As Object
    
    ' 设置工作表
    Set ws1 = Sh_before
    Set ws2 = Sh_after

    ' 创建Word应用和文档
    Set wApp = CreateObject("Word.Application")
    wApp.Visible = True
    Set wDoc = wApp.Documents.Add
    
    ' 获取最后一行
    lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 初始化变量
    startRow1 = 2
    currentValue = ws1.Cells(startRow1, 1).Value

    ' 循环遍历行
    For currentRow = 3 To lastRow1 + 1
        If ws1.Cells(currentRow, 1).Value <> ws1.Cells(startRow1, 1).Value Then
            endRow1 = currentRow - 1
            
            ' 在Sh_after中查找匹配项
            Set searchRange = ws2.Range(ws2.Cells(1, 1), ws2.Cells(lastRow2, 1))
            Set match = searchRange.Find(what:=currentValue, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            
            If Not match Is Nothing Then
                firstMatch = match.Address
                startRow2 = match.Row
                endRow2 = startRow2 ' 初始化结束行
                
                ' 查找同组最后一行
                Do
                    Set match = searchRange.FindNext(match)
                    If match.Address = firstMatch Then Exit Do
                    endRow2 = match.Row
                Loop

                ' 复制模板图表为临时对象（避免修改原模板）
                Set tempChartObj = Sh_data.ChartObjects("PQ_Graph").Duplicate
                tempChartObj.Name = "Temp_PQ_Graph"
                With tempChartObj.Chart
                    ' 修改图表标题
                    .ChartTitle.Text = currentValue
                    
                    ' 更新系列数据
                    ' PQ_before
                    .SeriesCollection(1).XValues = ws1.Range(ws1.Cells(startRow1, 4), ws1.Cells(endRow1, 4))
                    .SeriesCollection(1).Values = ws1.Range(ws1.Cells(startRow1, 5), ws1.Cells(endRow1, 5))
                    ' PQ_After
                    .SeriesCollection(2).XValues = ws2.Range(ws2.Cells(startRow2, 4), ws2.Cells(endRow2, 4))
                    .SeriesCollection(2).Values = ws2.Range(ws2.Cells(startRow2, 5), ws2.Cells(endRow2, 5))
                    ' Current_Before
                    .SeriesCollection(3).XValues = ws1.Range(ws1.Cells(startRow1, 4), ws1.Cells(endRow1, 4))
                    .SeriesCollection(3).Values = ws1.Range(ws1.Cells(startRow1, 7), ws1.Cells(endRow1, 7))
                    ' Current_After
                    .SeriesCollection(4).XValues = ws2.Range(ws2.Cells(startRow2, 4), ws2.Cells(endRow2, 4))
                    .SeriesCollection(4).Values = ws2.Range(ws2.Cells(startRow2, 7), ws2.Cells(endRow2, 7))
                End With
                
                ' 复制临时图表为图片并粘贴到Word末尾
                tempChartObj.Chart.CopyPicture xlScreen, xlPicture
                wDoc.Content.End.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
                
                ' 删除临时图表
                tempChartObj.Delete
                
                ' 插入分页符（如果不是最后一个图表）
                If currentRow < lastRow1 Then
                    wDoc.Content.End.InsertBreak Type:=wdSectionBreakNextPage
                End If
                
                ' 清空剪贴板
                Application.CutCopyMode = False
            End If
            
            ' 切换到下一组数据
            currentValue = ws1.Cells(currentRow, 1).Value
            startRow1 = currentRow
        End If
    Next currentRow
    
    MsgBox "完成"
    ' 释放对象
    Set wDoc = Nothing
    Set wApp = Nothing
End Sub

额外说明 #

临时图表的使用彻底避免了原图表与Word图片的关联，确保每张图片都是独立的静态内容；wDoc.Content.End保证图片按顺序追加，不会出现覆盖问题；分页逻辑的优化让代码更易维护。

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