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

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

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

・イメージ図

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

■フローチャート

■プログラム仕様

インプット	処理内容	アウトプット
–	シート名をセットする。 「検索結果」シート 「検索対象」シート	–
–	「検索結果」シート初期化処理 ・開始時間（C2セル） ・終了時間（C3セル） ・検索結果一覧表（6行目以降）	–
–	「No.」列出力用の初期値（1）をセットする。	–
–	行カウンタの初期値（6）をセットする。 ※一覧の結果を6行目から出力するため。	–
–	検索開始時間を出力する。	【セルの値】 「検索結果」シート タイムスタンプ
「検索対象」シートの図形	【ループ処理開始】 図形の数だけ繰り返し	–
–	「No.」列に番号を出力する。	【セルの値】 「検索結果」シート 1から連番
「検索対象」シートの図形	「図形名」列に図形の名前を出力する。	【セルの値】 「検索結果」シート 図形の名前
「検索対象」シートの図形	「テキスト」列に図形に記載したテキストを出力する。	【セルの値】 「検索結果」シート テキスト
–	「No.」と「行カウンタ」をインクリメントする。	–
–	検索終了時間を出力する。	【セルの値】 「検索結果」シート タイムスタンプ
–	終了メッセージを出力する。	【メッセージボックス】 「終了」
–	シートオブジェクトを解放する。	–

■サンプルコード

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

■実行結果