Selecting all Shape(s) within the ActiveCell

Is there an efficient way to select all of the drawing objects within the current cell into a ShapeRange? My worksheet has several hundred drawing objects. Some cells may contain up to 12 drawing objects. I need to find all of the drawing objects which are located within the ActiveCell.

I could do this using the following code by looping through all of the shapes on the sheet, but is there anything more efficient?
Dim TheseShapes(1 To 12) As Variant
Counter = 1
ThisRow = Selection.Row
ThisCol = Selection.Column
For Each sh In ActiveSheet.Shapes
If sh.TopLeftCell.Row = ThisRow Then
If sh.TopLeftCell.Column = ThisCol Then
TheseShapes(Counter) = sh.Name
Counter = Counter + 1
End If
End If
Next
ActiveSheet.Shapes.Range(TheseShapes).Select

Thanks for any help.