Excelの任意のシートの選択されたセル上に含まれるオートシェイプの種類と色別に数をカウントする

Sheet1は情報出力用のシートとして次の様な状態に。

Sheet2に適当にオートシェイプの図形を配置し、任意のセル範囲を選択状態にする。

マクロは標準モジュールとして次のコードを貼り付け。

Sub ShapeCounterFromSelectedRange()

    Dim shp As Shape
    Dim TargetRange As Variant
    Dim ShapeAndCollarArray As Object
    Set ShapeAndCollarArray = CreateObject("Scripting.Dictionary")
    
    '入OutPutSheetの設定　　　　　　↓ここを変える
    Const OutPutSheet As String = "Sheet1"
    Const ReadedSheet As String = "Sheet2"


    '過去データのクリア　　　　↓OutPutSheetの1行目はタイトル行とし、2行目以降をクリア
    Sheets(OutPutSheet).Range("A2:D6000").ClearContents
    Sheets(OutPutSheet).Range("A2:D6000").Interior.ColorIndex = 0
    


    '読み取りシートの選択レンジ＝選択されているセル範囲をGet
    Sheets(ReadedSheet).Activate
    TargetRange = ActiveWindow.RangeSelection.Address(False, False)


    'Getしたレンジ＝セル範囲に対する繰り返し処理
    For Each shp In Range(TargetRange).Worksheet.Shapes

        Sheets(ReadedSheet).Activate
        Dim MinimumRangeOfShpIncluded As Range
        Set MinimumRangeOfShpIncluded = Range(shp.TopLeftCell, shp.BottomRightCell)
        
        '範囲内外の識別
        If Not Intersect(MinimumRangeOfShpIncluded, Range(TargetRange)) Is Nothing Then
            If Intersect(MinimumRangeOfShpIncluded, Range(TargetRange)).Address _
            = MinimumRangeOfShpIncluded.Address Then

                ' ここにshapeオブジェクトごとに行う処理を書く
            Dim tmp As Variant
            tmp = Split(shp.Name)
            tmp = Replace(shp.Name, tmp(UBound(tmp)), "")
            
            Sheets(OutPutSheet).Activate
                Dim index As String
                index = tmp & "_" & shp.Fill.ForeColor
                index = Replace(index, " ", "")
                On Error Resume Next
                ShapeAndCollarArray.Add index
                On Error GoTo 0
                ShapeAndCollarArray.Item(index) = ShapeAndCollarArray.Item(index) + 1
            
            
            End If
        End If
    Next


    '図形＆色の組み合わせ結果の書き出し
    With Sheets(OutPutSheet)
    j = 2
        For Each varDic In ShapeAndCollarArray
          On Error Resume Next
          tmp = Split(varDic, "_")
          .Cells(j, 1).Value = tmp(0)
          .Cells(j, 2).Value = tmp(1)
'          .Cells(j, 2).Interior.Color = tmp(1) 'セルに色付け
          On Error GoTo 0
          
          .Cells(j, 3).Value = ShapeAndCollarArray.Item(varDic)
          j = j + 1
        Next
    End With
    
End Sub

これを実行すると、次のように選択された範囲内の、オートシェイプの名前と塗りつぶし色の組み合わせ毎に数をカウントした結果をSheet1へ出力する。

ミソはdictionaryオブジェクト＝連想配列の機能を使って形と色の組み合わせの重複のないリストを作りつつ数をカウントしているところか。

ちなみにこのコードはChatgptではなくいろいろググったコードをパクって組み合わせて半日がかり作ったが、後日Chatgptで指示してみたらテストまで含めて30分くらいでほぼ同等の事が出来た。

まさにChatgpt恐るべし。ちょっとしたVBA屋の価値は無くなってしまった。