添加Sheet4_new后Excel宏向Word书签粘贴时出现5941错误

问题描述 #

原有Excel宏可正常将表格、图表复制粘贴到带指定书签的Word模板中。新增Sheet4_new工作表及对应Word书签后，宏仅能粘贴部分内容（含新增工作表的内容），但提示部分图表不存在，调试器高亮代码行：myDoc.Bookmarks(ChartBookmarkArray(BookmarkCounter)).Range.Select，未粘贴的图表/表格均触发该错误，重新添加书签后问题依旧。

原宏代码（中文注释版） #

' 目标工作表数组
TabArray = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4_new", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9")
  
' 表格区域和图表名称数组
TableArray = Array("J15:L24", "A4:I14", "I16:K23", "B4:H15")
ChartArray = Array("Chart 1", "Chart 2")

' Word目标书签数组（表格）
TableBookmarkArray = Array("Sheet1", "Sheet1Table", "Sheet2", "Sheet2Table", "Sheet3", "Sheet3Table", "Sheet4_new", "Sheet4_newTable", "Sheet5", "Sheet5Table", "Sheet6", "Sheet6Table", "Sheet7", "Sheet7Table", "BlankTable", "Sheet8", "Sheet9", "Sheet9Table")
' Word目标书签数组（图表）
ChartBookmarkArray = Array("Sheet1Chart", "Sheet1Chart2", "Sheet2Chart", "Sheet2Chart2", "Sheet3Chart", "Sheet3Chart2", "Sheet4_newChart", "Sheet4_newChart2", "Sheet5Chart", "Sheet5Chart2", "BlankChart", "BlankChart", "BlankChart", "BlankChart", "Sheet8Chart", "Sheet8Chart2", "Sheet9Chart", "Sheet9Chart2")

' 书签计数器（用于遍历两个数组）
BookmarkCounter = 1

' 优化代码执行
Application.ScreenUpdating = False
Application.EnableEvents = False

' 初始化Word应用及目标文档
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Activate
WordFilePath = "locationoncomputer"
Set myDoc = WordApp.Documents.Open(WordFilePath & "nameofdoc.docx")

' 循环复制粘贴Excel表格和图表到Word
For x = LBound(TabArray) To UBound(TabArray)
    ActiveWorkbook.Worksheets(TabArray(x)).Activate

    ' 设置表格区域切换索引及数据判断单元格
    If x = 2 Then
        RangeSwitcher = 1
        IsThereSomething = ThisWorkbook.Worksheets(TabArray(x)).Range("K23").Value
        'ElseIf x = 4 Or x = 5 Then
        'RangeSwitcher = 5
        'IsThereSomething = ThisWorkbook.Worksheets(TabArray(x)).Range("J19").Value
    Else
        RangeSwitcher = 3
        IsThereSomething = ThisWorkbook.Worksheets(TabArray(x)).Range("J20").Value
    End If

    ' 遍历当前工作表的两个图表和表格
    For y = 1 To 2
        ' 复制表格（非Sheet7时复制所有，Sheet7仅y=2时复制）
        If x <> 7 Then
            Set tbl = ThisWorkbook.Worksheets(TabArray(x)).Range(TableArray(RangeSwitcher))
            tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            ' 粘贴到Word对应书签位置
            myDoc.Bookmarks(TableBookmarkArray(BookmarkCounter)).Range.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
                Placement:=wdInLine, DisplayAsIcon:=False
        ElseIf y = 2 Then
            Set tbl = ThisWorkbook.Worksheets(TabArray(x)).Range(TableArray(RangeSwitcher))
            tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            myDoc.Bookmarks(TableBookmarkArray(BookmarkCounter)).Range.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
                Placement:=wdInLine, DisplayAsIcon:=False
        End If

        ' 设置粘贴表格的替代文本
        For Each iShape In WordApp.ActiveDocument.InlineShapes
            If iShape.AlternativeText = "" Then
                Set pShape = iShape
                pShape.AlternativeText = "table"
                Exit For
            End If
        Next

        ' 处理图表粘贴（非Sheet5、Sheet6时执行）
        If x <> 5 And x <> 6 Then
            ' 判断是否有数据，无数据则替换为文本
            If IsThereSomething = 0 Then
                myDoc.Bookmarks(ChartBookmarkArray(BookmarkCounter)).Range.Select
                myDoc.Bookmarks(ChartBookmarkArray(BookmarkCounter)).Range.Text = NothingReplacementTextArray(BookmarkCounter)
            Else
                ' 复制对应图表
                With ActiveSheet.ChartObjects(ChartArray(y))
                    .Activate
                    .Select
                End With
                ActiveChart.ChartArea.Copy

                ' 粘贴到Word对应书签位置
                myDoc.Bookmarks(ChartBookmarkArray(BookmarkCounter)).Range.Select
                myDoc.Bookmarks(ChartBookmarkArray(BookmarkCounter)).Range.Text = ""
                WordApp.ActiveDocument.Application.Selection.PasteSpecial Link:=False, DataType:=14, _
                    Placement:=wdInLine, DisplayAsIcon:=False

                ' 设置粘贴图表的缩放及替代文本
                For Each iShape In WordApp.ActiveDocument.InlineShapes
                    If iShape.AlternativeText = "" Then
                        Set pShape = iShape
                        pShape.ScaleHeight = 65
                        pShape.ScaleWidth = 65
                        pShape.AlternativeText = "chart"
                        Exit For
                    End If
                Next
            End If
        End If

        ' 回到当前工作表的C2单元格
        ThisWorkbook.Worksheets(TabArray(x)).Range("C2").Select

        ' 切换到下一个书签
        BookmarkCounter = BookmarkCounter + 1
        ' 切换到当前工作表的第二个表格区域
        RangeSwitcher = RangeSwitcher + 1
    Next y
Next x

问题分析与修复方案 #

核心问题 #

1. 数组索引不匹配：VBA数组默认是0索引，但代码中BookmarkCounter从1开始，导致跳过数组第一个元素，后续索引越界无法找到对应书签。
2. ChartArray索引越界：ChartArray仅包含2个元素（索引0、1），但循环y从1到2，使用ChartArray(y)会访问索引2，超出数组范围触发“图表不存在”错误。
3. RangeSwitcher超出范围：部分分支中RangeSwitcher初始值为3，加1后变为4，超出TableArray的最大索引3，导致表格区域引用失败。

具体修复步骤 #

1. 修正书签计数器初始值
   将BookmarkCounter初始值改为0，匹配数组0索引：

BookmarkCounter = 0

2. 修正ChartArray索引调用
   将ChartArray(y)改为ChartArray(y-1)，对应数组的0、1索引：

With ActiveSheet.ChartObjects(ChartArray(y-1))
    .Activate
    .Select
End With

3. 限制RangeSwitcher范围
   修改RangeSwitcher的更新逻辑，避免超出TableArray的索引范围：

' 替换原RangeSwitcher更新代码
If y = 1 Then
    RangeSwitcher = RangeSwitcher + 1
Else
    ' 重置为当前工作表的初始RangeSwitcher值
    If x = 2 Then
        RangeSwitcher = 1
    Else
        RangeSwitcher = 3
    End If
End If

4. 可选优化：避免Select/Activate
   直接引用工作表对象，减少ActiveSheet依赖，降低错误概率：

' 替换原Activate代码
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(TabArray(x))
' 后续用ws代替ActiveSheet/ThisWorkbook.Worksheets(TabArray(x))

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