Excel VBA ツール : オートシェイプ内の文字列をセルに一覧出力する

今回は、オートシェイプの文字列を一覧に出力してくれる Excel VBA のツールを作ってみたのでシェアしますね。

こんにちは、ゆう(@ProgYuki)です。

普段仕事をする中で頻繁にExcelを使うと思うのですが、

「オートシェイプに書いてある文字列をセルに出力したい」

っていう場面ないですか？

私は今まで何度もありました。

オートシェイプは視覚的に表現したい場合には有用なのですが、データとして扱うにはとても不便なので、基本的にあらゆる場面で乱用するのはやめていただきたいわけですが、チームの中にいろんなコメントをオートシェイプに書いて残す方とかたまにいますよね。

また、オートシェイプでフローチャートを視覚的にを作った上で、それを工程表としてデータベースのようにまとめたいってこともあると思います。

私は以前BPR（業務改善）コンサルティングの会社にいた時にプロセスフローと工程表の両方を成果物として作る必要があったので、

「オートシェイプの文字列をセルに一覧で出力できたら便利だな〜」

ってよく思ってました。

それで今結構余裕があるので、プログラミングの勉強と業務効率化を兼ねて作ってみました！

のでシェアしますね。

同じようなニーズがある方やVBAの勉強してみたい方は、この記事内にコードも全表示しているので、参考にしていただければと思います。

Excel VBA ツール : オートシェイプ内の文字列を一覧に出力する
1. マクロツールの機能、使用用途、使い方
2. VBA コードの表示

Excel VBA ツール : オートシェイプ内の文字列を一覧に出力する

マクロツールの機能、使用用途、使い方

このツールの機能は、

Excel ブックに含まれる全てのシートの全てのオートシェイプの文字列を抽出して、

シート名
オートシェイプ名
オートシェイプ内の文字列

を指定したセルに一覧に出力する、というものです。

使用用途は、想定としては

オートシェイプに記載されたコメントを一覧表示して対応の漏れをなくしたい
フローチャートから工程表作成の手間を省きたい

てな感じです。

使い方によってはいろんなところで使えるツールだと思います。

コードをコピーする場所やプログラムの起動の仕方は後ほど説明しますが、使い方としては、

何かしらのオートシェイプがある状態で
VBAプログラムを起動して
文字列一覧を出力したいセルを指定すると
自動的に文字列一覧のテーブルが作成される

という流れになります。

画像つきで示すと、

例として適当にオートシェイプを作ってみました。

各オートシェイプ内に書いてある文字列（text1 , text 2 ..etc）が今回セルに出力したい文字列です。

起動の仕方はいろいろとあります。

ご自身でも調べてみると良いと思いますが、一番わかりやすい方法としては、

「開発」→「マクロ」

と進むと実行できるマクロの一覧が表示されるので、そこで今回は「shapeObjectList」という名前にしているので、それを選択して「実行」を押せば実行されます。

うまくできましたかね？
もし、何かエラー等があれば、コメントかTweetでご連絡いただけると幸いです。

今回のツールは起動するとポップアップが出てきて、出力先のセルを指定できるようにしてます。

適当なセルをクリックして指定ください。

セルを指定した後に「OK」をクリックすれば自動的に一覧の表が作成されます。

VBA コードの表示

コードの全文は下記の通りです。

Sub accelerate()

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

End Sub

Sub clearAccelerate()

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Sub shapeObjectList()

On Error GoTo Err

    Dim sheets As Worksheet, i As Integer, m As Integer, O As Shape, thisSheet As Worksheet
    Set thisSheet = ActiveSheet
   
    Dim rng As Range
    Set rng = Application.InputBox(prompt:="Choose the cell to open the table", Type:=8)
    
    Dim n As Integer

    i = rng.Row
    m = rng.Column

    Call accelerate

Done:

    With thisSheet
        .Cells(i, m).Value = "Sheet Name"
        .Cells(i, m + 1).Value = "Object Name"
        .Cells(i, m + 2).Value = "Object Texts"
    End With
    
    With thisSheet.Range(Cells(i, m), Cells(i, m + 2))
        .Interior.ColorIndex = 48
        .Font.ColorIndex = 2
        .Font.Bold = True
    End With
    
    For Each sheets In ActiveWorkbook.Worksheets
        If sheets.Shapes.Count > 0 Then
            For Each O In sheets.Shapes
                thisSheet.Cells(i + 1, m).Value = sheets.Name
                thisSheet.Cells(i + 1, m + 1).Value = O.Name
                If O.Name Like "Comment*" Then
                    thisSheet.Cells(i + 1, m + 2).Value = "-"
                Else
                    If O.TextFrame2.HasText Then
                        thisSheet.Cells(i + 1, m + 2).Value = O.TextFrame2.TextRange.Text
                    Else
                        thisSheet.Cells(i + 1, m + 2).Value = "-"
                    End If
                End If
                i = i + 1
            Next O
        End If
    Next sheets

    For n = 1 To 3
        thisSheet.Columns(m).EntireColumn.AutoFit
        m = m + 1
    Next n
    
    Call clearAccelerate
    Exit Sub

Err:
End Sub

Sub accelerate()

With Application

.ScreenUpdating = False

.DisplayAlerts = False

.EnableEvents = False

.Calculation = xlCalculationManual

End With

End Sub

Sub clearAccelerate()

With Application

.ScreenUpdating = True

.DisplayAlerts = True

.EnableEvents = True

.Calculation = xlCalculationAutomatic

End With

End Sub

Sub shapeObjectList()

On Error GoTo Err

Dim sheets As Worksheet, i As Integer, m As Integer, O As Shape, thisSheet As Worksheet

Set thisSheet = ActiveSheet

Dim rng As Range

Set rng = Application.InputBox(prompt:="Choose the cell to open the table", Type:=8)

Dim n As Integer

i = rng.Row

m = rng.Column

Call accelerate

Done:

With thisSheet

.Cells(i, m).Value = "Sheet Name"

.Cells(i, m + 1).Value = "Object Name"

.Cells(i, m + 2).Value = "Object Texts"

End With

With thisSheet.Range(Cells(i, m), Cells(i, m + 2))

.Interior.ColorIndex = 48

.Font.ColorIndex = 2

.Font.Bold = True

End With

For Each sheets In ActiveWorkbook.Worksheets

If sheets.Shapes.Count > 0 Then

For Each O In sheets.Shapes

thisSheet.Cells(i + 1, m).Value = sheets.Name

thisSheet.Cells(i + 1, m + 1).Value = O.Name

If O.Name Like "Comment*" Then

thisSheet.Cells(i + 1, m + 2).Value = "-"

Else

If O.TextFrame2.HasText Then

thisSheet.Cells(i + 1, m + 2).Value = O.TextFrame2.TextRange.Text

Else

thisSheet.Cells(i + 1, m + 2).Value = "-"

End If

i = i + 1

Next O

End If

Next sheets

For n = 1 To 3

thisSheet.Columns(m).EntireColumn.AutoFit

m = m + 1

Next n

Call clearAccelerate

Exit Sub

Err:

End Sub

どこにコードをコピーすれば良いのか
VBAマクロを使用する上での注意点

については下記の記事で詳しく書いているので、そちらを参考にされてください。

この記事もツール紹介の記事ですが、「VBA プログラムの表示」の項目の後に詳しいコピーの仕方や注意点について書いてます。

Excel VBA で仕事効率化 : リンク付き INDEX を自動作成しExcel資料を読みやすくする！

今回は、 Excel VBA のマクロ機能でリンク付き INDEX を自動作成し、Excel資料を読みやすくして仕事効率化する方法をシェアします！「Excelの仕事を効率化したい！」「VBAに興味があって、人のプログラムを見て学習したい！」という方にとって役に立つ内容かと思います。

ということで本日は以上になります。

私もまだまだVBA含めプログラミングを学習中の身なので、

「もっとこうした方が効率的に書けるよ！」
「こんな業務効率化したいんだけど、VBAでできるかな？」

など、ご指摘やアイディアなどをいただけると嬉しいです！

また、Excel VBAを独学したい方向けに記事を書きましたので、興味がある方はご参考にされてみてください↓

Excel VBA を最も効率的に独学する方法

仕事にルーティン業務が多い方ほどVBAの力を爆発的に発揮して業務効率化できるので、VBAを勉強しようと考えたことがある方も多いのではないでしょうか。今回は私が6年ほど Excel VBA を使っていて最も効率的だと考える独学方法をお伝えしたいと思います。

それでは本日もお読みいただきありがとうございました。

Twitter(@ProgYuki)でも情報発信しているので、ぜひフォロー、いいね、RT等お願いします！

ゆう

Excel VBA ツール : オートシェイプ内の文字列を一覧に出力する

マクロ ツール の機能、使用用途、使い方

VBA コードの表示

コメント

マクロツールの機能、使用用途、使い方