VBA Group multiple shapes in each cell

[jetiUser]

Hi,

Need a little help to modify this code to do the following:

It needs to group all shapes that could be in each cell in column G (but only if it has more than one)
Each cell could have different shapes and number of shapes (a picture, ovals, arrows ..)

I tried to modify the original code from this thread to do so.


http://www.mrexcel.com/forum/excel-questions/505613-select-group-shapes-within-range-2.html

Option Explicit

Sub GroupShapesWithinCells()

Dim aShapes() As String
Dim oShape As Shape
Dim rRegion As Range
Dim Cnt As Long
Dim Rng As Range
Dim g As Range

For Each oShape In ActiveSheet.Shapes

If oShape.Type = msoGroup Then
oShape.Ungroup
End If

Next oShape

Set Rng = Range("G12", Range("G65536").End(xlUp))

For Each g In Rng

Cnt = 0
For Each oShape In ActiveSheet.Shapes

If Application.Union(g, Range(oShape.TopLeftCell, oShape.BottomRightCell)).Address = g.Address Then
Cnt = Cnt + 1
ReDim Preserve aShapes(1 To Cnt)
aShapes(Cnt) = oShape.Name
End If

Next oShape

If Cnt > 1 Then
ActiveSheet.Shapes.Range(aShapes).Group
End If

Next g

MsgBox "Done!"

End Sub

 

[MickG]

Try :-

[COLOR=Navy]Sub[/COLOR] MG17Dec59
Dim Sp [COLOR=Navy]As[/COLOR] Shape
[COLOR=Navy]Dim[/COLOR] Ray()
[COLOR=Navy]Dim[/COLOR] p [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
p = 0
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Sp [COLOR=Navy]In[/COLOR] ActiveSheet.Shapes
    [COLOR=Navy]If[/COLOR] Sp.Type = msoAutoShape [COLOR=Navy]Then[/COLOR]
        [COLOR=Navy]If[/COLOR] Not Intersect(Range("G:G"), Sp.TopLeftCell) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
            ReDim Preserve Ray(p)
            Ray(p) = Sp.Name
            p = p + 1
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Sp
[COLOR=Navy]If[/COLOR] p > 0 [COLOR=Navy]Then[/COLOR] ActiveSheet.Shapes.Range(Ray).Group
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[jetiUser]

Hi,

I jut tried. I got an error on

If p > 0 Then ActiveSheet.Shapes.Range(Ray).Group

changed it to:

If p > 1 Then ActiveSheet.Shapes.Range(Ray).Group

Now the code steps fine but its not grouping the shapes.

 

[MickG]

So if you change the last bit of code as below and ensure the shapes are NOT grouped , does this return a Group Name

Dim Gr As Shape
If p > 1 Then
Set Gr = ActiveSheet.Shapes.Range(Ray).Group
MsgBox Gr.Name
End If

 

[jetiUser]

No, it does not return any group names.

So if you change the last bit of code as below and ensure the shapes are NOT grouped , does this return a Group Name

Dim Gr As Shape
If p > 1 Then
Set Gr = ActiveSheet.Shapes.Range(Ray).Group
MsgBox Gr.Name
End If

 

[jetiUser]

I've played and modified the code and sometimes it works, and sometimes it throws a "1004 error" on this line:

If Not Intersect(oShape.TopLeftCell, rRegion) Is Nothing Then

sub grouptest2()

Dim aShapes() As String
Dim oShape As Shape
Dim Rng As Range
Dim rRegion As Range
Dim g As Range
Dim Cnt As Long

For Each oShape In ActiveSheet.Shapes
    If oShape.Type = msoGroup Then
        oShape.Ungroup
    End If
Next oShape

Set Rng = Range("B12", Range("B65536").End(xlUp))
For Each g In Rng
    Set rRegion = g.Offset(0, 5)
    Cnt = 0
    For Each oShape In ActiveSheet.Shapes
        If Not Intersect(oShape.TopLeftCell, rRegion) Is Nothing Then
            Cnt = Cnt + 1
            ReDim Preserve aShapes(1 To Cnt)
            aShapes(Cnt) = oShape.Name
        End If
    Next oShape
    If Cnt > 1 Then
        ActiveSheet.Shapes.Range(aShapes).Group
    End If
    Set rRegion = Nothing
    Next g
MsgBox "Done"

End Sub

 

[MickG]

Are you shapes "Autoshapes", See VbHelp for definition.

 

[jetiUser]

Yes, as far as I can tell.
Usually there are only one picture (inserted) and one other shape (oval, circle or arrow) in each cell.

**Ran the following code to delete all the shapes (just to make sure). Deletes everything.

Sub DeleteShapes()
Dim oShape As Shape
For Each oShape In ActiveSheet.Shapes
oShape.Delete
Next Shp
End Sub

Are you shapes "Autoshapes", See VbHelp for definition.

 

[jetiUser]

The following does what I want, most of the time. I can run the same code on the same sheet with no issues x number of times. After it fails on a "1004 application-defined or object-defined" error on this line, then it wont run anymore. Until I close the workbook and it will run again x number of times.

If Not Application.Intersect(oShape.TopLeftCell, rRegion) Is Nothing Then

Sub GroupShapes2()

Dim aShapes() As String
Dim oShape As Shape
Dim Rng As Range
Dim rRegion As Range
Dim g As Range
Dim Cnt As Long

For Each oShape In ActiveSheet.Shapes

    If oShape.Type = msoGroup Then
        oShape.Ungroup
    End If

Next oShape
Set Rng = Range("B12", Range("B65536").End(xlUp))
    
For Each g In Rng
    Set rRegion = g.Offset(0, 5)
    Cnt = 0

    For Each oShape In ActiveSheet.Shapes
        If Not Application.Intersect(oShape.TopLeftCell, rRegion) Is Nothing Then
            Cnt = Cnt + 1
            ReDim Preserve aShapes(1 To Cnt)
            aShapes(Cnt) = oShape.Name
        End If
        
    Next oShape

    If Cnt > 1 Then
        ActiveSheet.Shapes.Range(aShapes).Group
    End If

    Set rRegion = Nothing
    Next g

MsgBox "Done"

End Sub