CODEWITHSUNDEEP
excelvbashapes
Ivan Fazaniuk
Ivan Fazaniuk

Reputation: 1070

VBA select shapes based on their positions

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

The Array should consist only Shapes 2 and 3 as per image above.

Upvotes: 2

Views: 15501

Answers (4)

Mikku
Mikku

Reputation: 6654

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.

Upvotes: 0

Brian Dias
Brian Dias

Reputation: 11

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

Upvotes: 1

Rory
Rory

Reputation: 34035

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

Upvotes: 4

Gary's Student
Gary's Student

Reputation: 96753

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

Upvotes: 2

Related Questions