如何检测Excel单元格是否包含形状？VBA代码问题求助

原代码的问题 #

你贴的代码逻辑完全偏离需求：它只是判断单元格值是否为空，根本没做任何形状的检测，自然无法实现“判断单元格是否存在形状”的核心需求。

正确实现代码 #

以下是符合需求的VBA代码，以向右移动6列（对应你原代码的Offset(0,6)）为例：

Sub CreateShapeInTargetCell()
    Dim ws As Worksheet
    Dim targetRng As Range
    Dim shp As Shape
    Dim shapeExists As Boolean
    Dim moveCols As Integer ' 向右移动的列数
    moveCols = 6 ' 可根据需求修改
    
    ' 指定目标工作表和初始单元格
    Set ws = ActiveSheet
    Set targetRng = ws.Range("B7")
    
    ' 检测初始单元格是否存在形状
    shapeExists = False
    For Each shp In ws.Shapes
        ' 判断形状是否完全位于目标单元格范围内（可根据需求调整判断逻辑）
        If shp.Top >= targetRng.Top And shp.Left >= targetRng.Left And _
           shp.Top + shp.Height <= targetRng.Top + targetRng.Height And _
           shp.Left + shp.Width <= targetRng.Left + targetRng.Width Then
            shapeExists = True
            Exit For
        End If
    Next shp
    
    ' 如果存在形状，向右移动指定列数，直到找到无形状的单元格
    Do While shapeExists
        Set targetRng = targetRng.Offset(0, moveCols)
        shapeExists = False
        For Each shp In ws.Shapes
            If shp.Top >= targetRng.Top And shp.Left >= targetRng.Left And _
               shp.Top + shp.Height <= targetRng.Top + targetRng.Height And _
               shp.Left + shp.Width <= targetRng.Left + targetRng.Width Then
                shapeExists = True
                Exit For
            End If
        Next shp
    Loop
    
    ' 在目标单元格位置创建形状（以矩形为例，可修改形状类型）
    Set shp = ws.Shapes.AddShape(msoShapeRectangle, targetRng.Left, targetRng.Top, _
                                targetRng.Width, targetRng.Height)
    ' 可添加形状样式设置，比如填充色、边框等
    shp.Fill.ForeColor.RGB = RGB(255, 200, 200)
    shp.Line.Visible = msoFalse
End Sub

代码说明 #

• 先遍历工作表所有形状，判断是否有形状完全位于目标单元格范围内（如果只需要判断形状是否覆盖单元格，可调整判断条件）
• 如果初始单元格有形状，就向右移动指定列数，重复检测，直到找到无形状的单元格
• 最后在目标位置创建矩形形状，可根据需求修改形状类型（比如msoShapeOval圆形）、尺寸、样式等

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