Select specific range if there is shape in it

[ceecee88]

Hi, I need little help please. I have been searching and only find the way to select the shapes in the specific area but I wanted to do the opposite. I wanted to select specific range if there is shape in it.

Code to select the object I have so far

Sub SelectShapes()
Dim shp As Shape
Dim r As Range

Set r = Range("D15:K28")

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
        shp.Select Replace:=False
Next shp
End Sub

This is what I wanted to achived
For example, there are 5 shapes in the sheet, I want to select range that there are shape in it starting from row 15 onward, so in the example below the range that need to be selected is D15:K28.

Any guidance will be much appreciated.

Thank you

 

[Snakehips]

@ceecee88 Do you mean something like below?

Sub SelectShapes()
Dim shp As Shape
Dim r As Range
Dim shpcount As Integer

Set r = Range("D15:K28")

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
        shpcount = shpcount + 1
Next shp

If shpcount > 0 Then r.Select
End Sub

 

[ceecee88]

@ceecee88 Do you mean something like below?

Sub SelectShapes()
Dim shp As Shape
Dim r As Range
Dim shpcount As Integer

Set r = Range("D15:K28")

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
        shpcount = shpcount + 1
Next shp

If shpcount > 0 Then r.Select
End Sub

Hi, Thank you for your help.
Not exactly, in the code above it is actually specify the range D15:K28, but I wanted the selected range to be dynamic. Basically the code need to determined where all the shapes are and select cell range behind all that shapes.


For example, if shape on the far right move to somewhere in Row 36/Column R then the selected range will have to be D15:R36 according to where all the shapes are (all the shape in this case are the shapes in row 15 onward).

Is that make sense?

Thank you!

 

[Snakehips]

I'm still a tad confused.
So , do you want to select the range encompassing ALL shapes or do you wish to specify all shapes from row ?? (eg row 15) downwards?

 

[ceecee88]

I'm still a tad confused.
So , do you want to select the range encompassing ALL shapes or do you wish to specify all shapes from row ?? (eg row 15) downwards?

I want to select dynamic range that has shape in it but this dynamic range start from row 15 onward, so if there is a shape in row 1-14 that doesn't count in the range I want to select.

Thank you

 

[Snakehips]

@ceecee88
Sorry for delay. I have had a broadband outage.
Maybe something along these lines?

Sub SelectShapes()
Dim Shp As Shape
Dim Lft As Integer
Dim Rht As Integer
Dim Bot As Integer

Lft = 999
Rht = 1
Top = 999

For Each Shp In ActiveSheet.Shapes

    If Shp.TopLeftCell.Row > 14 Then
        Lft = Application.WorksheetFunction.Min(Lft, Shp.TopLeftCell.Column)
        Top = Application.WorksheetFunction.Min(Top, Shp.TopLeftCell.Row)
        Rht = Application.WorksheetFunction.Max(Rht, Shp.BottomRightCell.Column)
        
        Bot = Application.WorksheetFunction.Max(Bot, Shp.BottomRightCell.Row)
    
    End If
   
Next Shp
 If Not (Lft = 999 And Top = 999) Then Range(Cells(Top, Lft), Cells(Bot, Rht)).Select
End Sub

 

[ceecee88]

@ceecee88
Sorry for delay. I have had a broadband outage.
Maybe something along these lines?

Sub SelectShapes()
Dim Shp As Shape
Dim Lft As Integer
Dim Rht As Integer
Dim Bot As Integer

Lft = 999
Rht = 1
Top = 999

For Each Shp In ActiveSheet.Shapes

    If Shp.TopLeftCell.Row > 14 Then
        Lft = Application.WorksheetFunction.Min(Lft, Shp.TopLeftCell.Column)
        Top = Application.WorksheetFunction.Min(Top, Shp.TopLeftCell.Row)
        Rht = Application.WorksheetFunction.Max(Rht, Shp.BottomRightCell.Column)
       
        Bot = Application.WorksheetFunction.Max(Bot, Shp.BottomRightCell.Row)
   
    End If
  
Next Shp
 If Not (Lft = 999 And Top = 999) Then Range(Cells(Top, Lft), Cells(Bot, Rht)).Select
End Sub

This is exactly what I need, thank you so much!