すべての図形内テキストをセルに出力するマクロ

マニュアルやフロー図などがExcelで作られていると、
ほとんどのテキストが図形内にあるということもよくあります。

私はこれを一旦セルに書き出す作業もよく行いますので、
それを一発でやってくれるマクロを作って対応しています。

需要があるかはわかりませんが、今回はこのマクロを紹介します。

実行型の便利マクロですので、
Excel起動時に裏で開かれる「個人用マクロブック」などに搭載して使ってください。

ツールバーやリボンにボタン配置すると便利です。
（流石にショートカットキーに登録する一軍マクロではなさそうなので）

マクロの仕様

ActiveSheetの全図形のテキストを新しいシートに書き出します。

⇩マクロを実行

テキスト内改行はそのままセル内改行にして、
1セルと1図形を1対1対応させています。

ソースコード

' 図形のテキストを取得
Sub すべての図形からテキストを取得する()
    
    Dim 対象シート As Worksheet: Set 対象シート = ActiveSheet
    
    ' テキストは新規シートに書き出す
    Dim 出力シート As Worksheet
    Set 出力シート = Workbooks.Add.Worksheets(1)
    出力シート.Columns.ColumnWidth = 50
    
    ' △ シートのすべてのシェイプを走査
    Dim R As Long: R = 1
    Dim シェイプ As Shape
    For Each シェイプ In 対象シート.Shapes

        ' シェイプのテキストを取得
        Dim 取得テキスト As String: 取得テキスト = ""
        On Error Resume Next
        取得テキスト = シェイプ.TextFrame.Characters.Text
        On Error GoTo 0
        
        ' テキストがあれば出力シートに書き出し
        If 取得テキスト <> "" Then
            出力シート.Cells(R, 1) = 取得テキスト
            R = R + 1
        End If
    
    Next ' ▽  シートのすべてのシェイプを走査
    
End Sub

解説

全シェイプをループしてテキストを書き出している単純なコードです。

テキストが取得できるかどうかの判定は面倒なので、
On Error Resume Nextを使って簡単に書きました。

わざわざ「取得テキスト」という変数を用意しているのは、

If シェイプ.TextFrame.Characters.Text <> "" Then

このコードがエラーの場合はTrueに分岐してしまうからです。

On Error Resume Next下においてIf文内でエラーが起きると、
True側に分岐するという誤認しやすい仕様があります。

On Error Resume Nextを使う場合はこの仕様に注意してください。

詳しくはこちらの記事をどうぞ。
www.limecode.jp