Excel VBA基于Sheet2取值在Sheet1对应单元格绘制圆形的代码异常排查

Sheet1....................................Sheet2

功能需求 #

开发VBA宏，基于Sheet2的单元格取值在Sheet1对应位置绘制圆形标记。宏需逐行读取Sheet2的单元格值，判断为Yes时在Sheet1同行的Yes列单元格绘制圆形，判断为No时在同行的No列单元格绘制圆形。

现有代码异常表现 #

• 所有绘制的圆形集中在Sheet1的单个单元格位置，运行过程中会逐次切换选中的单元格
• 移除For i = 0 To 4循环与对应判断逻辑后，圆形会无差别绘制在Sheet1两个目标范围的所有单元格上

原代码片段 #

Sub DrawCricles()
Dim Arng As Range, drawRng As Range, infoRng As Range, YesRng As Range, NoRng As Range, 
Set drawRng = Application.Selection
Set infoRng = Worksheets("Sheet2").Range("A1:A5") 'All the values in this range is either Yes/No
Set YesRng = Worksheets("Sheet1").Range("A1,A2,A3,A4,A5") 'All the values in this range is Yes
Set NoRng = Worksheets("Sheet1").Range("C1,C2,C3,C4,C5") 'All the values in this range is No

For i = 0 To 4
    NoRng(i).Select
    If infoRng(i).Value = "NO" Then
        NoRng(i).Select
        For Each Arng In drawRng.Areas
            With Arng
            x = Arng.Height * 0.1
            y = Arng.Width * 0.1
                Application.Worksheets("Sheet1").Ovals.Add Top:=.Top - x, Left:=.Left - y, _
                Height:=.Height + 2 * x, Width:=.Width - 5 * y
                With Application.Worksheets("Sheet1").Ovals(Worksheets("Sheet1").Ovals.Count)
                    .Interior.ColorIndex = xlNone
                    .ShapeRange.Line.Weight = 1.25
                End With
            End With
        Next
    Else
        YesRng(i).Select 
        For Each Arng In drawRng.Areas
            With Arng
            x = Arng.Height * 0.1
            y = Arng.Width * 0.1
                Application.Worksheets("Sheet1").Ovals.Add Top:=.Top - x, Left:=.Left + y * 4, _
                Height:=.Height + 2 * x, Width:=.Width - 3 * y
                With Application.Worksheets("Sheet1").Ovals(Worksheets("Sheet1").Ovals.Count)
                    .Interior.ColorIndex = xlNone
                    .ShapeRange.Line.Weight = 1.25
                End With
            End With
        Next
    End If
Next
End Sub

逻辑缺陷排查 #

1. 基础语法错误
   原代码的Dim变量声明行末尾多了个逗号，会触发编译报错，导致代码无法正常运行。
2. Range索引取值错误
   VBA中多单元格Range的Item索引是从1开始计数的，原代码从i=0开始循环，会错误取到Range的基类引用；同时YesRng、NoRng都是非连续单元格组成的Range，按索引取值时和预期的同行对应关系不匹配。
3. 核心逻辑错误
   原代码设置drawRng = Application.Selection，且画圆时的位置参数全部取自这个用户初始选中的范围，完全没有用到循环判断出来的目标单元格的位置。因此无论循环到哪一行，画出来的圆都会落在最初选中的单元格位置，所有图形自然堆叠在一起。
4. 冗余操作拉低运行效率
   代码中反复调用.Select方法切换选中单元格，不仅会造成界面上选中状态频繁跳动，还会额外拖慢运行速度，实际上绘制形状完全不需要选中目标单元格。
5. 缺少异常兼容逻辑
   原代码没有对历史绘制的图形做清理，多次运行会导致圆形重复堆积；同时判断单元格值时没有做大小写兼容，容易因为值的大小写差异导致判断失效。

修正后可直接运行的代码 #

Sub DrawCricles()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim infoRng As Range, YesRng As Range, NoRng As Range
    Dim targetCell As Range
    Dim rowIdx As Long
    Dim x As Double, y As Double
    
    ' 绑定目标工作表
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 清除Sheet1上所有历史绘制的椭圆，避免重复堆积
    ws1.Ovals.Delete
    
    ' 绑定固定范围
    Set infoRng = ws2.Range("A1:A5")
    Set YesRng = ws1.Range("A1,A2,A3,A4,A5")
    Set NoRng = ws1.Range("C1,C2,C3,C4,C5")
    
    ' 循环从1开始匹配Range的索引规则
    For rowIdx = 1 To infoRng.Cells.Count
        ' 判断Sheet2对应行的取值，匹配对应的目标单元格
        If UCase(infoRng.Cells(rowIdx).Value) = "NO" Then
            Set targetCell = NoRng.Cells(rowIdx)
            ' No列的圆形位置参数
            x = targetCell.Height * 0.1
            y = targetCell.Width * 0.1
            ws1.Ovals.Add _
                Top:=targetCell.Top - x, _
                Left:=targetCell.Left - y, _
                Height:=targetCell.Height + 2 * x, _
                Width:=targetCell.Width - 5 * y
        Else
            Set targetCell = YesRng.Cells(rowIdx)
            ' Yes列的圆形位置参数
            x = targetCell.Height * 0.1
            y = targetCell.Width * 0.1
            ws1.Ovals.Add _
                Top:=targetCell.Top - x, _
                Left:=targetCell.Left + y * 4, _
                Height:=targetCell.Height + 2 * x, _
                Width:=targetCell.Width - 3 * y
        End If
        
        ' 统一设置圆形样式
        With ws1.Ovals(ws1.Ovals.Count)
            .Interior.ColorIndex = xlNone
            .ShapeRange.Line.Weight = 1.25
        End With
    Next rowIdx
    
    ' 释放对象
    Set targetCell = Nothing
    Set infoRng = Nothing
    Set YesRng = Nothing
    Set NoRng = Nothing
End Sub

修正效果 #

• 去掉了所有冗余的单元格Select操作，运行时不会出现界面选中状态跳动的问题
• 画圆的位置参数全部取自当前循环对应的目标单元格，不再依赖用户初始选中的范围
• 循环索引从1开始，完全匹配VBA Range的索引规则，能准确对应每一行的Yes/No判断结果
• 新增了历史图形清理逻辑，多次运行不会出现图形堆积的问题
• 增加了取值大小写兼容判断，避免因为单元格值大小写不一致导致判断失效

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