Select a Shape that Intersects (touches) a Cell (range) using VBA

[michaelch2934]

Using VBA code, I will be placing a shape somewhere within a large cell range. But FIRST I NEED TO REMOVE THE SHAPE that may already be there. I know the shape will intersect or touch a certain cell (G13). So, I need the code to simply select this shape and then, I can move it to another location on the sheet. Because there are other shapes on the same sheet, I can't do a general 'select all' command. Just the shape that intersects G13. Thanks in advance.

 

[Yongle]

One way to do this would be to name the shape when created and simply delete the shape before creating the next one with the same name

Here is example code - modify to match your requirements

Sub AddShape()
    Dim shp As Shape, G13 As Range
    With ActiveSheet
'delete previous shape if it exists
        On Error Resume Next
        .Shapes("ShapeToBeDeleted").Delete
        On Error GoTo 0
'add new shape and name it
        Set G13 = .Range("G13")
        .Shapes.AddShape(msoShapeRoundedRectangle, G13.Left, G13.Top, 100, 25).Select
        Set shp = .Shapes(ActiveSheet.Shapes.Count)
        shp.Name = "ShapeToBeDeleted"
        shp.TextFrame.Characters.Text = "Created " & Now
        G13.Select
    End With
End Sub

 

[Yongle]

If top left corner of shape is inside the cell then can simply use this

Sub DeleteShapes()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Address(0, 0) = "G13" Then shp.Delete
    Next
End Sub

 

[michaelch2934]

While this may 'work' as a workaround, I still would like to know how to 'select' a shape based on it intersecting a specific cell. I know it can either totally 'cover' the range (cell) or simply 'touch' it (intercept) and be 'selected'. Thanks for your reply and the unconventional method of solving my problem.

 

[michaelch2934]

This is more like what I had in mind. But, rather than Delete. I simply want to 'select' the shape so I can send it to another location on the sheet.

So, instead of 'Then shp.Delete', could it be 'Then shp.Select'?

Thanks for taking time to work on this for me.

 

[ravisingh]

If top left corner of shape is inside the cell then can simply use this

Sub DeleteShapes()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Address(0, 0) = "G13" Then shp.Delete
    Next
End Sub

Top left corner of shape in cell G13 will not cover all situations - e.g. if bottom right corner is in G13, the code wont detect it though the shape still overlaps G13

The following code should cover this

Sub RngShapeOverlap()    Set Rng = Range("G13")
    Dim Shp As Shape
    With Rng
        RngTop = .Top: RngLft = .Left: RngBot = .Offset(1, 0).Top: RngRt = .Offset(0, 1).Left
    End With
    ShpCount = ActiveSheet.Shapes.Count
    If ShpCount = 0 Then MsgBox ("No shapes in worksheet"): Exit Sub
    OlapShpCount = 0
    For i = 1 To ShpCount
        Set Shp = ActiveSheet.Shapes(i)
        ShpTop = Shp.Top: ShpLft = Shp.Left: ShpBot = ShpTop + Shp.Height: ShpRt = ShpLft + Shp.Width
        If ShpRt < RngLft Or ShpLft > RngRt Then HLap = False Else HLap = True
       
        If ShpBot < RngTop Or ShpTop > RngBot Then VLap = False Else VLap = True
        
        If HLap = True And VLap = True Then OlapShpCount = OlapShpCount + 1: Set SelShp = Shp
    Next 'Shp
    If OlapShpCount = 0 Then
        MsgBox ("No overlapping shape found")
    Else
        MsgBox (OlapShpCount & " overlapping shape(s) found")
        Application.Goto Rng
        SelShp.Select
    End If
End Sub

 

[ravisingh]

The code finds shape(s) whose 'bounding rectangle' overlaps with G13 - it is possible to have irregular shapes which do not visually appear to overlap with G13, but whose bounding rectangle does touch/overlap G13.

Also, there may be multiple such shapes - the code selects the most recently found such shape - the code could be tweaked to include ALL such shapes in the selection so they could be moved in one go.

 

[My Aswer Is This]

A interesting post for sure.

In post 5 you said:

I simply want to 'select' the shape so I can send it to another location on the sheet.​

If you already know the shape is near rang("G13") and all you want to do is select it so you can put it some place else.

Why would you need a script to do this?

Why not select the shape manually and do what you want with it?

 

[Yongle]

I have just reread your post and you wanted to MOVE not delete. oops

Here is a code which
- counts how many shapes intersect cell G13
- selects a shape so that it can be moved

Sub IsThereAShapeToMove()
    Dim shp As Shape, shpRng As Range, c As Integer
    With ActiveSheet
        For Each shp In .Shapes
            Set shpRng = .Range(shp.TopLeftCell.Address, .Range(shp.BottomRightCell.Address))
            If Not Intersect(shpRng, .Range("G13")) Is Nothing Then
                c = c + 1: shp.Select
            End If
        Next shp
    End With
    If c > 1 Then MsgBox c & " intersecting shapes"
End Sub

 

[ravisingh]

I have just reread your post and you wanted to MOVE not delete. oops

Here is a code which
- counts how many shapes intersect cell G13
- selects a shape so that it can be moved

Sub IsThereAShapeToMove()
    Dim shp As Shape, shpRng As Range, c As Integer
    With ActiveSheet
        For Each shp In .Shapes
            Set shpRng = .Range(shp.TopLeftCell.Address, .Range(shp.BottomRightCell.Address))
            If Not Intersect(shpRng, .Range("G13")) Is Nothing Then
                c = c + 1: shp.Select
            End If
        Next shp
    End With
    If c > 1 Then MsgBox c & " intersecting shapes"
End Sub

The code above will not find shapes whose bounding rectangle just touches any point or line on the periphery of G13
For example