Determine shape object position

Juan Pablo González said:

This function will work for Rectangular callouts, giving you the value of the cell where the callout ends.

Code:

Function GetCalloutValue(ByVal shapeName As String, _
                         Optional parentRange As Range, _
                         Optional volatile As Boolean = True) As Variant
   Dim shp As Excel.Shape
   Dim WS As Worksheet
   Dim top As Single
   Dim left As Single
   Dim testRange As Range
   Dim foundHorizontal As Boolean
   Dim foundVertical As Boolean
   
   Application.volatile volatile
   
   If Not parentRange Is Nothing Then
      Set WS = parentRange.Worksheet
   Else
      If TypeName(Application.Caller) = "Range" Then
         Set WS = Application.Caller.Worksheet
      Else
         GetCalloutValue = CVErr(xlErrNum)
         Exit Function
      End If
   End If
   
   On Error Resume Next
   Set shp = WS.Shapes(shapeName)
   On Error GoTo 0
   
   If shp Is Nothing Then
      GetCalloutValue = CVErr(xlErrValue)
      Exit Function
   End If
   
   'Only do for Rectangular Callout for now
   If shp.AutoShapeType <> msoShapeRectangularCallout Then
      GetCalloutValue = CVErr(xlErrValue)
      Exit Function
   End If
   
   'Get mid point of the rectangle
   top = shp.top + shp.Height / 2
   left = shp.left + shp.Width / 2
   
   'Adjustments(1) holds the number of "widths" where the callout ends
   left = left + shp.Width * shp.Adjustments(1)
   
   'Adjustments(2) holds the number of "heights" where the callout ends
   top = top + shp.Height * shp.Adjustments(2)
   
   'Now find the range that has those coordinates, starting from the TopLeftCell
   
   Set testRange = shp.TopLeftCell
   
   foundHorizontal = False
   foundVertical = False
   Do While Not (foundHorizontal And foundVertical)
      If Not foundHorizontal Then
         Select Case left
         Case Is < testRange.left
            Set testRange = testRange.Offset(, -1)
         Case Is > testRange.left + testRange.Width
            Set testRange = testRange.Offset(, 1)
         Case Else
            foundHorizontal = True
         End Select
      End If
      
      If Not foundVertical Then
         Select Case top
         Case Is < testRange.top
            Set testRange = testRange.Offset(-1)
         Case Is > testRange.top + testRange.Height
            Set testRange = testRange.Offset(1)
         Case Else
            foundVertical = True
         End Select
      End If
   Loop
   
   GetCalloutValue = testRange.Value
End Function

You can use it like

=GETCALLOUTVALUE("ShapeName")

or if the shape is in another worksheet, just pass any range that belongs to that worksheet

=GETCALLOUTVALUE("ShapeName", Sheet2!A1)

Click to expand...