你的核心痛点是Word中目标图表位置会变动，原代码固定定位到第2页的方式完全没法适配这种场景。要解决这个问题，关键是给每个需要替换的Word图表设置唯一可识别的标识，让代码能精准找到它们，不管位置怎么变。

前置准备：给Word现有图表添加唯一标识 #

打开你的Word文档，选中每个需要替换的图表，右键选择「设置图片格式」（或「设置形状格式」），在「大小与属性」→「可选文字」里，给每个图表设置和Excel中对应图表名称完全一致的Alt文本（比如Excel里的Chart1对应Word图表的Alt文本设为"Chart1"）。这是代码能精准匹配的关键。

优化后的完整VBA代码 #

Sub ReplaceWordChartsWithExcelLinks()
    Dim xlWB As Workbook
    Dim xlWS As Worksheet
    Dim chtObj As ChartObject
    
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim wrdShp As Word.InlineShape
    Dim targetRange As Word.Range
    
    ' 1. 打开目标Excel文件
    Set xlWB = Workbooks.Open("D:\Charts.xlsx", UpdateLinks:=False)
    Set xlWS = xlWB.Worksheets("Graph")
    
    ' 2. 启动Word并打开目标文档（如果Word已打开，直接获取实例）
    On Error Resume Next
    Set wrdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wrdApp = New Word.Application
    End If
    On Error GoTo 0
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open("D:\DASHBOARD.docx")
    
    ' 3. 遍历Excel中的每个图表，匹配Word中的对应图表并替换
    For Each chtObj In xlWS.ChartObjects
        ' 复制Excel图表（带链接源）
        chtObj.Chart.ChartArea.Copy
        
        ' 遍历Word中的所有内嵌形状，找匹配Alt文本的图表
        For Each wrdShp In wrdDoc.InlineShapes
            ' 匹配条件：形状是OLE对象（图表）且Alt文本和Excel图表名称一致
            If wrdShp.Type = wdInlineShapeOLEObject And _
               wrdShp.AlternativeText = chtObj.Name Then
                
                ' 记录图表位置，删除旧图表
                Set targetRange = wrdShp.Range
                wrdShp.Delete
                
                ' 在原位置粘贴带链接的Excel图表
                targetRange.PasteSpecial Link:=True, DataType:=wdPasteOLEObject
                ' 给新粘贴的图表设置相同的Alt文本，方便下次替换
                targetRange.InlineShapes(1).AlternativeText = chtObj.Name
                
                Exit For ' 找到匹配的就退出内层循环
            End If
        Next wrdShp
        
        Application.CutCopyMode = False
    Next chtObj
    
    ' 4. 清理对象
    Set wrdShp = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set chtObj = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    
    MsgBox "图表替换完成！", vbInformation
End Sub

关键优化点说明 #

1. 避免使用Selection：直接操作Range对象，比依赖Selection更稳定，不会因为光标位置出错。
2. 动态匹配图表：通过AlternativeText（Alt文本）和Excel图表的Name做关联，不管Word图表位置怎么变动，只要标识正确就能找到。
3. 兼容Word已打开的情况：用GetObject先尝试获取已运行的Word实例，避免重复打开。
4. 保留替换位置：删除旧图表前先记录它的Range，确保新图表粘贴到原位置。

注意事项 #

• 运行代码前，需要在VBA编辑器中勾选「工具」→「引用」→「Microsoft Word xx.x Object Library」（xx.x是你的Word版本号）。
• 确保Excel中每个图表的Name是唯一的，Word中对应图表的Alt文本和它完全一致（大小写敏感）。

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