【VBA】図形（オートシェイプ）に文字列を入れ、高さを最適化する

先日、仕事で「ExcelでER図を作ってくれ」という要望があり対応しました。ER図というのは以下のようなDBのリレーションを表したものですね。

（上記例ではリレーションはまだ引いていませんが…）

とにかく上記のような、図形（オートシェイプ）にDBの列を記載するという作業をひたすら対応する羽目になりました。

しかし300テーブル以上あり、すぐに無理だと悟ったので

• 図形を作成する
• 図形に文字列を入れる
• 図形のサイズを調整する

ここまでを一括で実行するマクロを作成しました。その内容について記載したいと思います。

図形を作成する

単純に図形を作成するだけで良ければ、オートシェープの作成をマクロ記録すればコードを得ることが出来ます。

Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, 200, 200)

↑実行結果

msoShapeRectangleは四角の図形を作るという指示

引数の2つ目と3つ目が挿入する位置、4つ目と5つ目がサイズとなります。

このソースを使用すれば、図形を量産することができそうです。

しかし今回の場合、下記のような図形にする必要がありました。（グループ化も必須）

マクロで複雑な表を作るのは面倒なので、テンプレートを用意しておいて、それをコピペすることにしました。

    ActiveSheet.Shapes.Range(Array("Group 1")).Select
    Selection.Copy
    ActiveSheet.Paste

“Group 1″の部分は図形に割り当てられている番号を指定します。

グループを作るごとにカウントアップしていくので、調べるにはマクロ記録してしまうのがいいと思います。

テンプレートが他のシートにある場合は

    Set sh1 = worksheets("Sheet1")
    Set sh2 = worksheets("Sheet2")
    sh1.Shapes.Range(Array("Group 1")).Select
    Selection.Copy
    sh2.select
    ActiveSheet.Paste

こんな感じでワークシートを指定すればいいです。

本来であればcopyとかクリップボードを使う操作はしたくないのだけど、使わないとちょっと面倒だったので楽しました。

図形に文字列を入れる

図形に文字を入れるコードを追加しました。

    Dim sp As Shape
    Set sp = ActiveSheet.Shapes.Range(Array("Group 1")).GroupItems(2)
    sp.TextFrame2.TextRange.Characters.Text = "上に入れる値"
    
    ActiveSheet.Shapes.Range(Array("Group 1")).Select
    Selection.Copy
    ActiveSheet.Paste

実行結果

「TextFrame2.TextRange.Characters.Text」で文字を挿入しています。ただ、その前にグループからオートシェープを抜き出さなければいけません。

グループ化した際に、GroupItemsのどちらにオブジェクトが置かれるかは正直あまり理解していないのですが、大体サイズの大きいほうからインデックスが小さくなる事が多いです。

上の図だと、でかい四角（下の四角）がインデックス0

小さい四角（上の四角）がインデックス1になります。

（正直、この辺の見識がないので、教えてくれると嬉しいです。）

高さを最適化する

オートシェープ内で文字を折り返すには、Chr(13) を使用します。

    Dim sp As Shape
    Set sp = ActiveSheet.Shapes.Range(Array("Group 1")).GroupItems(1)
    sp.TextFrame2.TextRange.Characters.Text = "下に入れる値" & Chr(13) & "2行目"
    
    ActiveSheet.Shapes.Range(Array("Group 1")).Select
    Selection.Copy
    ActiveSheet.Paste

最後にオブジェクトの高さを文字によって最適化します。最適化する方法は、フォントサイズや漢字の有無などにより異なります。

仮にデフォルトのフォントサイズ11ptの場合は…

sp.GroupItems(1).Height = 20 + 行数 * 13.5

この式でほぼ最適化出来ました。

これと違うフォントサイズの場合は、検証により最適な高さを探すしかなさそうです。

後はループさせる場合には、ActiveSheet.Pasteをする前に、セルをSelectして場所が被らないようにしていったほうがいいです。