【Excel VBA】図形の名前とテキストを一覧に出力する

■実装するプログラムの概要

任意のシートに配置している図形について、図形の名前とテキストを一覧に出力する。

・イメージ図

「検索対象」シートに設置している図形の名前とテキストを「検索結果」シート「の一覧出力」ボタン押下時に一覧表に出力する。

■フローチャート

■プログラム仕様

■サンプルコード

Option Explicit

' 「図形一覧出力」ボタン押下時の処理
Public Sub Btn_Click_GetShape()

    Dim shtname_result  As Worksheet    ' 「検対結果」シートを格納する変数
    Dim shtname_search  As Worksheet    ' 「検索対象」シートを格納する変数
    Dim iNo             As Integer      ' No.出力カウンタ
    Dim irow            As Integer      ' 行カウンタ
    Dim shp             As Shape        ' 図形オブジェクトを格納する変数
    
On Error GoTo Btn_Click_GetShape_ERROR

    ' シート名をセット
    Set shtname_result = Sheets("検索結果")
    Set shtname_search = Sheets("検索対象")
    
    ' 「検索結果」シートの初期化
    With shtname_result
        .Cells(2, 3).Value = ""
        .Cells(3, 3).Value = ""
        .Range("6:1048576").ClearContents
    End With
    
    ' 初期値をセット
    ' No.出力：1をセット
    iNo = 1
    
    ' 「検対結果」シート6行目をスタート行とする
    irow = 6
    
    ' 検索開始時間を出力
    shtname_result.Cells(2, 3).Value = Now
    
    ' 「検索対象」シートにフォーカス
    With shtname_search

        ' 図形の数だけループ処理
        For Each shp In .Shapes

            ' 「No.」列に番号を付与
            shtname_result.Cells(irow, 2).Value = iNo
            ' 「図形名」列に図形の名前を付与
            shtname_result.Cells(irow, 3).Value = shp.Name
            ' 「テキスト」列に図形に記載したテキストを付与
            shtname_result.Cells(irow, 4).Value = shp.TextFrame2.TextRange.Text

            ' インクリメント処理
            iNo = iNo + 1
            irow = irow + 1
        Next
    End With
    
    ' 検索終了時間を出力
    shtname_result.Cells(3, 3).Value = Now

    ' 終了メッセージを出力
    MsgBox "終了"

' 終了処理へ
GoTo Btn_Click_GetShape_Exit

' エラーハンドリング
Btn_Click_GetShape_ERROR:

    ' エラーメッセージを出力
    MsgBox Err.Description

    ' 終了処理へ
    GoTo Btn_Click_GetShape_Exit

' 終了処理
Btn_Click_GetShape_Exit:

    ' シートを解放
    Set shtname_search = Nothing
    Set shtname_result = Nothing
    
End Sub

■実行結果