Ungroup All Shapes in Active Worksheet

[Stefan_Sand]

hello,

i got this nice lines of code, which works very fine for me to group all shapes in my active worksheet.
how can i alter the code to ungroup the shapes if i want to it by code instead of do it by hand?

Sub group_all()
Dim varArr() As Variant
Dim shp As Shape
Dim intAnzahl As Integer
For Each shp In ActiveSheet.Shapes
intAnzahl = intAnzahl + 1
ReDim Preserve varArr(1 To intAnzahl)
varArr(intAnzahl) = shp.Name
Next
Set shp = ActiveSheet.Shapes.Range(varArr).Group
shp.Name = "All"
End Sub

Thanks in advance,
stefan

[HansV]

In this particular situation, you end up with a single shape named "All" on the active sheet, so the following is sufficient to ungroup:

Code: Select all

Sub UngroupAll()
  ActiveSheet.Shapes("All").Ungroup
End Sub

A more general macro allows for multiple grouped shapes on the sheet:

Code: Select all

Sub UngroupAll()
  Dim i As Long
  On Error Resume Next
  For i = ActiveSheet.Shapes.Count To 1 Step -1
    ActiveSheet.Shapes(i).Ungroup
  Next i
End Sub

If you have grouped shapes that contain grouped shapes among its members, it becomes more complicated.

[Stefan_Sand]

hi Hans,

thank You for your quick post; both solutions work fine for me. As an additional but not necessary question: is it so possible to group or ungroup even all shapes of one type - like freform, or a connector?

Stefan

[HansV]

To group shapes of a specific type:

Code: Select all

Sub GroupSpecific(ShapeType As MsoShapeType)
  Dim varArr() As Variant
  Dim shp As Shape
  Dim intAnzahl As Integer
  For Each shp In ActiveSheet.Shapes
    If shp.Type = ShapeType Then
      intAnzahl = intAnzahl + 1
      ReDim Preserve varArr(1 To intAnzahl)
      varArr(intAnzahl) = shp.Name
    End If
  Next shp
  Set shp = ActiveSheet.Shapes.Range(varArr).Group
  shp.Name = "AllFreeforms"
End Sub

Call like this to group freeforms:

Code: Select all

Sub GroupFreeforms()
  Call GroupSpecific(msoFreeform)
End Sub

Ungrouping is more tricky - a grouped shape has type msoGroup, reagardless of the composition of the group. So you'd have to inspect the shapes within the group:

Code: Select all

Sub UngroupSpecific(ShapeType As MsoShapeType)
  Dim i As Long
  Dim shp As Shape
  Dim f As Boolean
  On Error Resume Next
  For i = ActiveSheet.Shapes.Count To 1 Step -1
    f = True
    With ActiveSheet.Shapes(i)
      If .Type = msoGroup Then
        For Each shp In .GroupItems
          If Not shp.Type = ShapeType Then
            f = False
            Exit For
          End If
        Next shp
        If f Then
          .Ungroup
        End If
      End If
    End With
  Next i
End Sub

Call like this to ungroup groups consisting entirely of freeforms:

Code: Select all

Sub UngroupFreeforms()
  Call UngroupSpecific(msoFreeform)
End Sub

[Stefan_Sand]

cool, thank you!

so i can easy adopt the code to group rectangles and so on.... ;-))

[HansV]

Here's a slightly improved version of the first macro; it lets you specify the name of the grouped shape.

To group shapes of a specific type:

Code: Select all

Sub GroupSpecific(ShapeType As MsoShapeType, GroupName As String)
  Dim varArr() As Variant
  Dim shp As Shape
  Dim intAnzahl As Integer
  For Each shp In ActiveSheet.Shapes
    If shp.Type = ShapeType Then
      intAnzahl = intAnzahl + 1
      ReDim Preserve varArr(1 To intAnzahl)
      varArr(intAnzahl) = shp.Name
    End If
  Next shp
  Set shp = ActiveSheet.Shapes.Range(varArr).Group
  shp.Name = GroupName
End Sub

Call like this to group freeforms:

Code: Select all

Sub GroupFreeforms()
  Call GroupSpecific(msoFreeform, "AllFreeforms")
End Sub

BTW, for rectangles, you must look at the AutoShapeType property instead of at the Type property, for the Type for rectangles is msoAutoShape. The AutoShapeType is msoShapeRectangle.

[Stefan_Sand]

hi Hans,

thanks for Your second reply and improvement as well. I will try to adopt it today and test it.

stefan