获取指定单元格内形状名称：VBA自定义函数返回空值问题

问题场景 #

工作表中存在通过VBA_Circle_Text宏创建的椭圆形形状，调用GetShapeName自定义函数获取指定单元格（如J10）对应的形状名称时返回空值，移除代码中的MergeArea后问题仍未解决。

原代码 #

测试及自定义函数代码 #

Sub Test()
    Debug.Print GetShapeName(Range("J10"))
End Sub

Function GetShapeName(cell As Range) As String
    Dim shp As Shape
    For Each shp In cell.Parent.Shapes
        If Not Application.Intersect(shp.TopLeftCell.MergeArea, cell) Is Nothing Then
            GetShapeName = shp.Name
            Exit Function
        End If
    Next shp
    GetShapeName = ""
End Function

创建椭圆的宏代码 #

Sub VBA_Circle_Text()
    Dim cel As Range, m As Double, n As Double
    Set cel = Application.Selection
    With cel
        m = .Height * 0.1
        n = .Width * 0.1
        Application.ActiveSheet.Ovals.Add Top:=.Top - m, Left:=.Left - n, Height:=.Height + 2.25 * m, Width:=.Width + 1.75 * n
        With Application.ActiveSheet.Ovals(ActiveSheet.Ovals.Count)
            .Interior.ColorIndex = xlNone
            With .ShapeRange.Line
                .Weight = 2
                .ForeColor.RGB = vbRed
            End With
        End With
    End With
    cel.Select
End Sub

问题原因 #

原函数通过shp.TopLeftCell判断形状与单元格的关联，但VBA_Circle_Text创建椭圆时，刻意将形状的左上角偏移到目标单元格外部（Top:=.Top - m、Left:=.Left -n），导致椭圆的TopLeftCell并非目标单元格（比如J10），而是其左上方的相邻单元格，因此Intersect判断无法匹配，返回空值。

修正方案 #

修改GetShapeName函数的判断逻辑，直接检查形状的边界是否与目标单元格存在重叠，而不是依赖TopLeftCell。

修正后的函数代码（精准坐标判断版） #

Function GetShapeName(cell As Range) As String
    Dim shp As Shape
    Dim shpTop As Double, shpLeft As Double
    Dim shpBottom As Double, shpRight As Double
    Dim cellTop As Double, cellLeft As Double
    Dim cellBottom As Double, cellRight As Double
    
    ' 获取单元格的边界坐标
    cellTop = cell.Top
    cellLeft = cell.Left
    cellBottom = cell.Top + cell.Height
    cellRight = cell.Left + cell.Width
    
    For Each shp In cell.Parent.Shapes
        ' 获取形状的边界坐标
        shpTop = shp.Top
        shpLeft = shp.Left
        shpBottom = shp.Top + shp.Height
        shpRight = shp.Left + shp.Width
        
        ' 判断形状与单元格是否存在重叠：排除完全不相交的情况
        If Not (shpBottom < cellTop Or shpTop > cellBottom Or shpRight < cellLeft Or shpLeft > cellRight) Then
            GetShapeName = shp.Name
            Exit Function
        End If
    Next shp
    GetShapeName = ""
End Function

说明 #

该方案通过坐标直接判断形状与单元格的矩形边界是否重叠，逻辑更严谨，能准确匹配那些偏移创建的椭圆形状，避免因TopLeftCell不在目标单元格导致的判断失败。

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