Excel图表批量复制到Word书签位置及删除问题咨询

需求：将Excel中16张图表复制到Word指定书签位置，以内联方式放置且不建立文件链接，后续更新时需先删除已粘贴的图表。

遇到的问题：Word的InlineShapes对象没有Name属性，但手动选中图表时，功能区会显示类似Picture 1的名称；使用现有删除代码时，部分图表无法被移除（所有图表均为内联类型、粘贴方式一致）。

现有代码情况 #

可正常运行的复制粘贴代码 #

' 通过书签定位，从当前工作簿复制图表
For i = 1 To 16
    Sheets(sheetnames(i)).Select
    ActiveSheet.ChartObjects(Chartlocn(i)).Activate
    ActiveChart.ChartArea.Copy
    
    With d.Bookmarks(Bookmarklocn(i)).Range
        .Select
        objW.Selection.PasteSpecial Link:=False, DataType:=15, Placement:=wdInLine, _
        DisplayAsIcon:=False
    End With
Next i

存在问题的删除代码（部分图表无法删除） #

j = d.InlineShapes.Count
            
counter = 0
For i = 1 To d.InlineShapes.Count
    counter = counter + 1
    MsgBox (i)
                
    'If d.InlineShapes.Item(counter).Type = _
        'wdInlineShapePicture Then
        d.InlineShapes.Item(counter).Select
        objW.Selection.Delete Unit:=wdCharacter, Count:=1 ' 宏录制生成的代码
    'Else
    'End If
Next i

解决方案 #

方案1：粘贴时标记图表，实现精准定位删除 #

核心思路是给粘贴后的图表添加唯一标识，后续删除时直接通过标识定位，避免依赖不稳定的索引。

方法A：利用书签关联图表

粘贴后重新更新书签范围，将图表包含在内，删除时直接清空书签内容（不会影响其他文本）：

' 优化后的复制粘贴代码，同时关联书签
For i = 1 To 16
    ' 跳过Select/Activate，直接操作图表对象
    Sheets(sheetnames(i)).ChartObjects(Chartlocn(i)).ChartArea.Copy
    
    With d.Bookmarks(Bookmarklocn(i))
        .Range.PasteSpecial Link:=False, DataType:=15, Placement:=wdInLine, DisplayAsIcon:=False
        ' 更新书签范围，确保包含刚粘贴的图表
        .Range = .Range
    End With
Next i

' 删除时直接清空对应书签的内容
For i = 1 To 16
    If d.Bookmarks.Exists(Bookmarklocn(i)) Then
        d.Bookmarks(Bookmarklocn(i)).Range.Delete
    End If
Next i

方法B：给InlineShape添加自定义标签

给每个粘贴的图表添加自定义标签，删除时根据标签筛选：

' 粘贴时添加自定义标签
For i = 1 To 16
    Sheets(sheetnames(i)).ChartObjects(Chartlocn(i)).ChartArea.Copy
    
    With d.Bookmarks(Bookmarklocn(i)).Range
        .PasteSpecial Link:=False, DataType:=15, Placement:=wdInLine, DisplayAsIcon:=False
        ' 获取刚粘贴的内联形状
        Dim shp As Word.InlineShape
        Set shp = .InlineShapes(.InlineShapes.Count)
        ' 添加自定义标签，标记为来自Excel的图表
        shp.Tags.Add Name:="ExcelImportedChart", Value:=CStr(i)
    End With
Next i

' 删除时筛选带标签的内联形状（反向遍历避免索引混乱）
Dim i As Integer
For i = d.InlineShapes.Count To 1 Step -1
    With d.InlineShapes(i)
        If .Tags.Exists("ExcelImportedChart") Then
            .Delete
        End If
    End With
Next i

方案2：修复现有删除逻辑 #

当前删除代码的问题是正向遍历：删除一个InlineShape后，后续元素的索引会前移，导致跳过部分图表。改成反向遍历即可解决：

' 反向遍历删除所有内联图片（对应粘贴的图表）
Dim i As Integer
For i = d.InlineShapes.Count To 1 Step -1
    With d.InlineShapes(i)
        If .Type = wdInlineShapePicture Then
            .Delete
        End If
    End With
Next i

额外优化：避免使用Select/Activate #

原复制代码中的Select和Activate会降低效率且易出错，改成直接操作对象：

' 精简后的复制粘贴代码
For i = 1 To 16
    Sheets(sheetnames(i)).ChartObjects(Chartlocn(i)).ChartArea.Copy
    d.Bookmarks(Bookmarklocn(i)).Range.PasteSpecial _
        Link:=False, DataType:=15, Placement:=wdInLine, DisplayAsIcon:=False
Next i

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