VBA select shapes based on their positions

Question

How do I select all shapes (array? range?) where the value in Cell \"A:Shape.TopLeftCell.Row\" = 0 ?

Answer 1

There is another way around of this. I came across this post while looking for a solution.

So here it is the Answer for anyone looking for a way around.

The Method goes like this:

Run a loop like this once to change the names of the Rectangles to the Address of their TopLeftCell

 Dim sh As Shape

 For Each sh In ActiveSheet.Shapes

    sh.Name = sh.TopLeftCell.Address

 Next sh

---

Now in any other code you can directly access the shape using:

ActiveSheet.Shapes(ActiveCell.Address).Select

This is one way you can achieve it. Though there doesn't exist a method that you are looking for.

You can change the ActiveCell.Address any range object or maybe just the text itself. It will take values like $D$4

Tried and Tested, it works Smoothly.

Answer 2

You can loop through the shapes on the sheet until you find one in the range. As someone else mentioned, selecting is often unnecessary.

Dim shp As shape
For Each shp In ActiveSheet.shapes
    If Not Intersect(yourselectedrange, shp.TopLeftCell) Is Nothing Then
         shp.Select
         Exit For
    End If
Next shp

Answer 3

Just as an alternative, you can reverse the logic and select as you go, then assign the selection to a shaperange if required:

Sub ShapePicker()
    Dim s As Shape
    Dim sr As ShapeRange
    Dim i As Long

    i = 1
    For Each s In ActiveSheet.Shapes
        If Cells(s.TopLeftCell.Row, "A").Value = 0 Then
            s.Select (i = 1)
            i = i + 1
        End If
    Next s
    Set sr = Selection.ShapeRange
End Sub

Answer 4

Build a ShapeRange that meets the criteria and then Select that ShapeRange

Sub ShapePicker()
    Dim s As Shape, sr As ShapeRange
    Dim Arr() As Variant
    Set mycell = Range("A:A").Find(What:=0, After:=Range("A1"))
    rrow = mycell.Row

    i = 1
    For Each s In ActiveSheet.Shapes
        If s.TopLeftCell.Row = rrow Then
            ReDim Preserve Arr(1 To i)
            Arr(i) = s.Name
            i = i + 1
        End If
    Next s

    Set sr = ActiveSheet.Shapes.Range(Arr)
    sr.Select

End Sub