Select and group shapes within a range

[orador]

I need to select, group, copy and then paste to another worksheet a selection of shapes wihtin the range ("K1:AA6"). Any help much apprciated.

 

[Domenic]

It's always best to start your own thread. Otherwise you're question get's buried in a thread and most people won't see it. So you're unlikely to get a response, or it would take a lot longer to get one.

Assuming that the sheet containing the shapes is the active sheet, the following macro will delete all shapes within the specified region. Change the specified region, accordingly.

Option Explicit

Sub DeleteShapesWithinRegion()

    Dim aShapes() As String
    Dim oShape As Shape
    Dim rRegion As Range
    Dim Cnt As Long
    
    Set rRegion = ActiveSheet.Range("B7:H14")
    
    Cnt = 0
    For Each oShape In ActiveSheet.Shapes
        If Application.Union(rRegion, Range(oShape.TopLeftCell, oShape.BottomRightCell)).Address = rRegion.Address Then
            Cnt = Cnt + 1
            ReDim Preserve aShapes(1 To Cnt)
            aShapes(Cnt) = oShape.Name
        End If
    Next oShape
    
    If Cnt > 0 Then
        ActiveSheet.Shapes.Range(aShapes).Delete
    Else
        MsgBox "No shapes found within region!", vbExclamation
    End If
    
End Sub

Hope this helps!

 

[Rick Rothstein]

It's always best to start your own thread. Otherwise you're question get's buried in a thread and most people won't see it. So you're unlikely to get a response, or it would take a lot longer to get one.

Assuming that the sheet containing the shapes is the active sheet, the following macro will delete all shapes within the specified region. Change the specified region, accordingly.

Option Explicit

Sub DeleteShapesWithinRegion()

    Dim aShapes() As String
    Dim oShape As Shape
    Dim rRegion As Range
    Dim Cnt As Long
    
    Set rRegion = ActiveSheet.Range("B7:H14")
    
    Cnt = 0
    For Each oShape In ActiveSheet.Shapes
        If Application.Union(rRegion, Range(oShape.TopLeftCell, oShape.BottomRightCell)).Address = rRegion.Address Then
            Cnt = Cnt + 1
            ReDim Preserve aShapes(1 To Cnt)
            aShapes(Cnt) = oShape.Name
        End If
    Next oShape
    
    If Cnt > 0 Then
        ActiveSheet.Shapes.Range(aShapes).Delete
    Else
        MsgBox "No shapes found within region!", vbExclamation
    End If
    
End Sub

Hope this helps!

Since we are doing deletions, your code can be simplified to this...

Sub DeleteShapesWithinRegion()
    Dim oShape As Shape
    Dim rRegion As Range
    
    Set rRegion = ActiveSheet.Range("B7:H14")
    
    For Each oShape In ActiveSheet.Shapes
        If Application.Union(rRegion, Range(oShape.TopLeftCell, oShape.BottomRightCell)).Address = rRegion.Address Then
            oShape.Delete
        End If
    Next oShape

End Sub

 

[Domenic]

Yeah, that was my first thought. But then I thought it might be more efficient to delete them in one go. Was I wrong?

 

[Rick Rothstein]

Yeah, that was my first thought. But then I thought it might be more efficient to delete them in one go. Was I wrong?

I actually hadn't thought about timing issues with deleting shapes before, but my gut tells me it wouldn't matter (at least not noticeably)... it is not like deleting rows where other rows (and their content) move up to fill the gap, which can be slow if done one-at-a-time as compared to the optimization that Excel seems to have "under the hood" when multiple rows are deleted at the same time. Besides, I have never thought of Union to be a particularly fast functionality when repeated over and over again. But even if there was a timing difference, I would guess the number of shapes that would be in a range as small as B7:H14 to be minimal, so any timing difference would be lost in the smallness of numbers.

 

[Domenic]

I actually hadn't thought about timing issues with deleting shapes before, but my gut tells me it wouldn't matter (at least not noticeably)... it is not like deleting rows where other rows (and their content) move up to fill the gap, which can be slow if done one-at-a-time as compared to the optimization that Excel seems to have "under the hood" when multiple rows are deleted at the same time. Besides, I have never thought of Union to be a particularly fast functionality when repeated over and over again. But even if there was a timing difference, I would guess the number of shapes that would be in a range as small as B7:H14 to be minimal, so any timing difference would be lost in the smallness of numbers.

Yeah, that seems reasonable to me. Thanks Rick!

 

[ojones]

Hi Domenic et Al;
It was the snippet from your original post on the subject I have been using but I wsa finding that depending on what other actions I have done on the spreadsheet I was getting this "400" error.
It turns out that within the shapes collection there are shapes that do not have an address that can be used in the application.union method without causing an error.
I have solved the problem by testing for msoFormControls and anything with a type msoNotPrimitiveShape before testing for where they are located. Seems to work fine now. The control that was causing the problem mostly was a validated dropdown box as part of the spreadsheet but the above has fixed it I think.

Thanks for the refinements from all the other also.