【VBA Personal】Excelシート上の選択範囲内の図形をグループ化するマクロ

!!編集中のため、現在この記事のコードは参照しないようにしてください

PERSONALに追加する

下記のコードをVBEのPERSONALに追加してください

※PERSONALについて知らない方は下記の記事を参考
https://vbabeginner.net/how-to-create-a-personal-macro-book/

Public Sub groupSelectedShapes()

    Application.OnKey "+^{g}", "groupSelectedShapes"

    Dim rngSelection As Range
    Dim selectionWidth As Single
    Dim selectionHeight As Single
    Dim targetShape As Shape
    
On Error GoTo ERR_HANDLER
    Set rngSelection = Selection
    selectionWidth = rngSelection.Left + rngSelection.width
    selectionHeight = rngSelection.Top + rngSelection.height
    
    Dim shapeWidth As Single
    Dim shapeHeight As Single
    Dim shapeCnt As Long
    shapeCnt = 0
    
    For Each targetShape In ActiveSheet.Shapes
        shapeWidth = targetShape.Left + targetShape.width
        shapeHeight = targetShape.Top + targetShape.height
        
        If rngSelection.Left < targetShape.Left And selectionWidth > shapeWidth And _
           rngSelection.Top < targetShape.Top And selectionHeight > shapeHeight Then
           shapeCnt = shapeCnt + 1

           If shapeCnt = 1 Then
               targetShape.Select
            Else
               targetShape.Select Replace:=False
            End If
            
        End If        
    Next
    
    If shapeCnt > 1 Then
        Selection.Group
        Exit Sub
    Else
        Call MsgBox(Prompt:="選択範囲内に2つ以上の図形が存在しません", Buttons:=vbExclamation, Title:="Error")
        Exit Sub
    End If
    
ERR_HANDLER:
    Call MsgBox(Prompt:="想定外エラーです。" & vbCrLf & "グループ化したい図形が入るようにセルを範囲選択し再実行してください。", Buttons:=vbExclamation, Title:="Error")
        
End Sub

ショートカットキーについて

Application.OnKey "+^{g}", "groupSelectedShapes"　のところは好きなショートカットに変えてください。
ショートカットの記述方法は「Application.OnKey」で調べればすぐ出てきますし、
下記の記事コード内のコメントブロックにも記載しています。

実行時の挙動

ショートカットキーからマクロ実行

選択範囲内に図形が２つ以上存在しないときはエラーメッセージ表示