グループ化されたオートシェイプに対して、グループ解除せずに処理を行う

やりたいこと

グループ化されたシェイプに対して、グループを解除せずに処理を行いたい。
特に、グループ化された図形がさらにグループ化されているようなケースを含めて処理したい。

参考: すべてのグループを解除する

以下のリンク先では、グループ化されたオートシェイプ・図形をすべてグループ解除するマクロです。
グループ化された図形がさらにグループ化されているようなケースでも、すべてグループ解除できます。
https://www.relief.jp/docs/018401.html

グループ化されたオブジェクトに対してループするマクロ

以下のマクロの「各Shapeに対する処理」というコメントに、各オートシェイプに対して行いたい処理を書けばよいです。
今回は、オートシェイプの名称をデバッグプリントに書き出すコードとしました。

Module1

Public Sub loopGroupedShape()
    Dim shp As Shape
    Dim gr_shp As Shape
    Dim gr As Collection

    Set gr = New Collection
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoGroup Then
            gr.Add shp
        Else
            '各Shapeに対する処理
            Debug.Print shp.Name
        End If
    Next

    Do While gr.Count > 0
        For Each gr_shp In gr
            For Each shp In gr_shp.GroupItems
                If shp.Type = msoGroup Then
                    gr.Add shp
                Else
                    '各Shapeに対する処理
                    Debug.Print shp.Name
                End If
            Next
            gr.Remove 1
        Next
    Loop

End Sub

使用例

マクロ実行対象

以下のようにグループ化された図形に対して、上記のマクロを実行します。

階層1

階層2

階層3

階層4

マクロ実行結果

イミディエイトウィンドウに、グループ化されたすべての図形の名前が表示されました。
このとき、マクロ実行後も、グループ化は解除されていません。

PowerPoint版

同様に、PowerPointでもGroup化した図形に対する処理ができます。
PowerPointの場合、ループの仕方を少し変えています。

Module1

Public Sub loopGroupedShape_PPT()

    Dim sld As Slide
    Dim shp As Shape
    Dim gr_shp As Shape
    Dim gr As Collection

    Set gr = New Collection

    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.Type = msoGroup Then
                gr.Add shp
            Else
                '各Shapeに対する処理
                Debug.Print shp.Name
            End If
        Next
    Next

    Do While gr.Count > 0
        For Each gr_shp In gr
            For Each shp In gr_shp.GroupItems
                If shp.Type = msoGroup Then
                    gr.Add shp
                Else
                    '各Shapeに対する処理
                    Debug.Print shp.Name
                End If
            Next
            gr.Remove 1
        Next
    Loop

End Sub