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]

The following macro will group all shapes within K1:AA6 of Sheet1, and copy/paste the group into Sheet2, where K1 is the top left cell of the grouped shapes. Note that any shape that does not fall completely within K1:AA6 will not be copied/pasted to Sheet2. However, the code can be changed to include them, if desired. Post back if this is the case.

Option Explicit
 
Sub test()
 
    Dim MyArray() As String
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim Rng As Range
    Dim ShpRng As Range
    Dim shp As Shape
    Dim Cnt As Long
 
    Set WS1 = Worksheets("Sheet1")  [COLOR=seagreen]'Change the sheet name, accordingly.[/COLOR]
    Set WS2 = Worksheets("Sheet2")  [COLOR=seagreen]'Change the sheet name, accordingly.[/COLOR]
 
    Set Rng = WS1.Range("K1:AA6")
 
    Cnt = 0
    For Each shp In WS1.Shapes
        Set ShpRng = WS1.Range(shp.TopLeftCell, shp.BottomRightCell)
        If Application.Union(Rng, ShpRng).Address = Rng.Address Then
            ReDim Preserve MyArray(Cnt)
            MyArray(Cnt) = shp.Name
            Cnt = Cnt + 1
        End If
    Next shp
 
    WS1.Shapes.Range(MyArray).Group.Copy
 
    [COLOR=seagreen]'Change the position of the top left cell for the group of shapes, accordingly[/COLOR]
    WS2.Range("K1").PasteSpecial
 
End Sub

 

[orador]

Hi Dominic

Thanks for responding so quickly, but I get a Run-time error 1004 "Specified parameter has an invalid value" at this line -
WS1.shapes.Range(MyArray).Group.Copy

Tried some varients but no joy!!

 

[Domenic]

When I run the code on Excel 2007, no such error occurs. In any case, try the following instead...

Option Explicit
 
Sub test()
 
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim Rng As Range
    Dim ShpRng As Range
    Dim shp As Shape
    Dim TopPos As Double
    Dim LeftPos As Double
 
    Application.ScreenUpdating = False
 
    Set WS1 = Worksheets("Sheet1")
    Set WS2 = Worksheets("Sheet2")
 
    Set Rng = WS1.Range("K1:AA6")
 
    For Each shp In WS1.Shapes
        Set ShpRng = WS1.Range(shp.TopLeftCell, shp.BottomRightCell)
        If Application.Union(Rng, ShpRng).Address = Rng.Address Then
            TopPos = shp.Top
            LeftPos = shp.Left
            shp.Copy
            With WS2
                .Activate
                .Paste
            End With
            With Selection
                .Left = LeftPos
                .Top = TopPos
            End With
        End If
    Next shp
 
    Application.ScreenUpdating = True
 
End Sub

 

[orador]

Ah! Should of said I'm running 2003 - Anyway this works now just not grouped, but thank you very much. for your help and speedy responses.

 

[Domenic]

Does this work on your version of Excel?

Option Explicit
 
Sub test()
 
    Dim MyArray() As String
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim Rng As Range
    Dim ShpRng As Range
    Dim shp As Shape
    Dim Cnt As Long
    Dim LeftPos As Double
    Dim TopPos As Double
 
    Application.ScreenUpdating = False
 
    Set WS1 = Worksheets("Sheet1")  
    Set WS2 = Worksheets("Sheet2")  
 
    Set Rng = WS1.Range("K1:AA6")
 
    Cnt = 0
    For Each shp In WS1.Shapes
        Set ShpRng = WS1.Range(shp.TopLeftCell, shp.BottomRightCell)
        If Application.Union(Rng, ShpRng).Address = Rng.Address Then
            ReDim Preserve MyArray(Cnt)
            MyArray(Cnt) = shp.Name
            Cnt = Cnt + 1
        End If
    Next shp
 
    WS1.Shapes.Range(MyArray).Group.Select
 
    With Selection
        LeftPos = .Left
        TopPos = .Top
        .Copy
    End With
 
    With WS2
        .Activate
        .Paste
    End With
 
    With Selection
        .Left = LeftPos
        .Top = TopPos
    End With
 
    Application.ScreenUpdating = True
 
End Sub

 

[orador]

No - still same problem at the same line as before. In last code your gave could the images be grouped post the insertion into WS2?

 

[Domenic]

Does this help? The following macro should first group the relevant shapes from Sheet1, then it should copy/paste the group to Sheet2...

Option Explicit
 
Sub test()
 
    Dim MyArray() [COLOR=red]As Variant[/COLOR]
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim Rng As Range
    Dim ShpRng As Range
    Dim shp As Shape
    Dim Cnt As Long
    Dim LeftPos As Double
    Dim TopPos As Double
 
    Application.ScreenUpdating = False
 
    Set WS1 = Worksheets("Sheet1")
    Set WS2 = Worksheets("Sheet2")
 
    Set Rng = WS1.Range("K1:AA6")
 
    Cnt = 0
    For Each shp In WS1.Shapes
        Set ShpRng = WS1.Range(shp.TopLeftCell, shp.BottomRightCell)
        If Application.Union(Rng, ShpRng).Address = Rng.Address Then
            ReDim Preserve MyArray(Cnt)
            MyArray(Cnt) = shp.Name
            Cnt = Cnt + 1
        End If
    Next shp
 
    [COLOR=red]WS1.Shapes.Range(MyArray).Select[/COLOR]
 
[COLOR=red]  With Selection.ShapeRange.Group[/COLOR]
[COLOR=red]      LeftPos = .Left[/COLOR]
[COLOR=red]      TopPos = .Top[/COLOR]
[COLOR=red]      .Copy[/COLOR]
[COLOR=red]  End With[/COLOR]
 
[COLOR=red]  With WS2[/COLOR]
[COLOR=red]      .Activate[/COLOR]
[COLOR=red]      .Paste[/COLOR]
[COLOR=red]  End With[/COLOR]
 
[COLOR=red]  With Selection.ShapeRange[/COLOR]
[COLOR=red]      .Left = LeftPos[/COLOR]
[COLOR=red]      .Top = TopPos[/COLOR]
[COLOR=red]  End With[/COLOR]
 
    Application.ScreenUpdating = True
 
End Sub

 

[orador]

Absolutely, I think we say this is resolved - thank you!

 

[ojones]

I am dealing with the same probelm of wanting to delete shapes within a region and have implemented the code from this thread which seems to work some of the time.
I have an issue with a "400" error message which I think is linked to the code coming accross an object in the shapes collection which does not have an excel address.
at least it is the application.union part of the code that is causing the trouble.
I don't know if I can use a try-catch solution in vba, but it seems to me there ought to be a way of stripping out anything not a drawing object?
I am using excel2010 on win7
Thanks for any help - not sure if this should be a new thread or not?