Word VBA宏求助：合并单元格内矩形绘制错位及循环消失问题

问题场景 #

现有15×3的表格，其中cell(3,3)合并了9行。需求：

• 在该合并单元格内写入“Text 1”
• 切换至下一段落后，绘制高10、宽100的彩色矩形，叠加同高度、宽度为前者25%的白色矩形
• 重复此操作3次（上下排列）

当前问题 #

• 彩色矩形会跳至cell(3,1)单元格
• 白色矩形虽留在cell(3,3)但循环中会消失
• 需要将所有矩形分组并锚定在cell(3,3)合并单元格内

原VBA代码 #

Sub DrawSkillLevelCharts(StartRow, StartColumn, paraNo, I)
    Dim leftPos As Single
    Dim topPos As Single
    Dim chartWidth As Single
    Dim barHeight As Single
    Dim superWidth As Single
    Dim startCell As cell
    Dim currentRange As Range
    Dim mainBarChart As Shape
    Dim superimposedBar As Shape
    barHeight = 10
    Set currentRange = myTable.cell(StartRow, StartColumn).Range.Paragraphs(paraNo).Range

    With currentRange
        .Collapse 0
        .Move Unit:=wdCharacter, Count:=1
        .Select
    End With
    leftPos = Selection.Information(wdHorizontalPositionRelativeToPage)
    topPos = Selection.Information(wdVerticalPositionRelativeToPage)
    chartWidth = 100
    superWidth = chartWidth * (I * 0.25)
            
    ' Draw main bar chart and anchor it to the cell
    Set mainBarChart = ActiveDocument.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, _ 
            chartWidth, barHeight, currentRange)
    mainBarChart.Fill.ForeColor.RGB = RGB(56, 86, 35)
    mainBarChart.Anchor = currentRange
    ' Draw superimposed white bar and anchor it to the cell
    Set superimposedBar = ActiveDocument.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, _
            superWidth, barHeight, currentRange)
    superimposedBar.Fill.ForeColor.RGB = RGB(255, 255, 255)
    superimposedBar.Anchor = currentRange
End Sub

解决方案 #

核心问题分析 #

1. 使用Selection获取位置易引发锚点偏移，尤其在合并单元格场景下
2. 未处理垂直偏移导致图形重叠或位置错误
3. 未对每组图形分组，无法保证锚点统一

具体修改步骤 #

• 弃用Selection，直接通过单元格范围计算图形内部坐标
• 累加垂直偏移量实现上下排列
• 对每组图形分组，绑定统一锚点
• 锁定锚点防止意外跳转

修正后的代码 #

Sub DrawSkillLevelCharts(StartRow As Integer, StartColumn As Integer, paraNo As Integer, I As Integer)
    Dim leftPos As Single
    Dim topPos As Single
    Dim chartWidth As Single
    Dim barHeight As Single
    Dim superWidth As Single
    Dim cellRange As Range
    Dim paraRange As Range
    Dim mainBarChart As Shape
    Dim superimposedBar As Shape
    Dim shapeGroup As Shape
    Dim verticalOffset As Single
    Dim spacing As Single ' 每组图形间距
    
    barHeight = 10
    spacing = 5 ' 可按需调整间距
    verticalOffset = (I - 1) * (barHeight + spacing) ' 当前组的垂直偏移
    
    ' 获取目标单元格和指定段落范围
    Set cellRange = myTable.Cell(StartRow, StartColumn).Range
    Set paraRange = cellRange.Paragraphs(paraNo).Range
    
    ' 计算图形在单元格内的位置（基于单元格左上角）
    leftPos = cellRange.Information(wdHorizontalPositionRelativeToPage) + 10 ' 左边距可调整
    topPos = paraRange.Information(wdVerticalPositionRelativeToPage) + verticalOffset
    
    chartWidth = 100
    superWidth = chartWidth * 0.25 ' 固定为前者25%，需按I递增可改为I*0.25
    
    ' 绘制彩色矩形并锁定锚点
    Set mainBarChart = ActiveDocument.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, _
            chartWidth, barHeight, cellRange)
    mainBarChart.Fill.ForeColor.RGB = RGB(56, 86, 35)
    mainBarChart.LockAnchor = True
    
    ' 绘制白色矩形并锁定锚点
    Set superimposedBar = ActiveDocument.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, _
            superWidth, barHeight, cellRange)
    superimposedBar.Fill.ForeColor.RGB = RGB(255, 255, 255)
    superimposedBar.LockAnchor = True
    
    ' 分组两个矩形，统一锚点
    Set shapeGroup = ActiveDocument.Shapes.Range(Array(mainBarChart.Name, superimposedBar.Name)).Group
    shapeGroup.Anchor = cellRange
    shapeGroup.LockAnchor = True
End Sub

' 调用示例（需确保myTable指向目标表格）
Sub RunDraw()
    Dim myTable As Table
    Set myTable = ActiveDocument.Tables(1) ' 假设为文档第一个表格
    
    ' 在cell(3,3)写入文本并添加段落分隔符
    myTable.Cell(3, 3).Range.Text = "Text 1" & vbCr
    
    ' 重复3次绘制
    Dim i As Integer
    For i = 1 To 3
        DrawSkillLevelCharts 3, 3, 2, i ' paraNo=2对应文本后的段落
    Next i
End Sub

关键说明 #

1. 位置计算改用单元格和段落的相对坐标，避免Selection引发的锚点错误
2. 通过verticalOffset控制每组图形的垂直位置，spacing可调整间距
3. LockAnchor = True确保图形锚点固定在目标单元格，不会跳转
4. 每组图形分组后，锚点统一绑定到单元格，后续操作更便捷

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