セルいっぱいに円シェイプを表示

はじめに
マクロの記録でコードを出力する
プログラムコードを改造
使い方
1. 注意点
まとめ
1. 関連記事:

はじめに

　予定表などで、セルの大きさに合わせた円（シェイプ）を表示させるVBAプログラムを書いてみましょう。
　と言っても、マクロの記録を改造すれば簡単に作れます。

マクロの記録でコードを出力する

　まずは、「開発」＞「マクロの記録」として、マクロの記録を起動させます。
次に、「挿入」＞「図」＞「図形」から「楕円」を選択して、シート上の適当な位置に楕円を描きます。

　続いて、描いた楕円を「塗りつぶしなし」にして「線の太さ」を調整します。（今回は線の太さを0.75）にしました。出来上がったら「開発」＞「記録終了」としてマクロの記録を終了させます。

　以下のようなコードが出力されると思います。

Sub Macro1()
'
' Macro1 Macro
'

'
    ActiveSheet.Shapes.AddShape(msoShapeOval, 50.5, 14.5, 46, 12).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 0.75
    End With
End Sub

　コードの赤線部分が楕円の位置、黄色線部分が「塗りつぶしなし」、青線が線の太さを示しています。
ここで、赤線の部分を書き換えれば、自由に楕円の位置を書き換えられます。

　楕円の位置は、シートウインドウの左上からのポイント（位置）で決めています。
値は４つありますが、それぞれ左（Left）、上（Top）、幅（Width）、高さ（Height）となっています。

　今回はプロシージャに汎用性を持たせてセルを指定するとその大きさに合わせ円を描くようにしてみたいと思います。

　プログラムコードを以下のように変更してみてください。

プログラムコードを改造

Sub MyShapeOval(rng As Range)
'
' Macro1 Macro
'

'
    ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, rng.Width, rng.Height).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 0.75
    End With
End Sub

　上記の下線部分を変更します。変更する内容としては、AddShapeの引数の Range 部分を変更します。こうすれば楕円をセルの枠内に収めることができるようになります。

　まずはプロシージャ名を MyShapeOval としました。次に引数に Range を取ります。これで引数にセルを指定してやれば楕円で囲まれるようになります。

　最後にAddShapeの引数の Range 部分を変更します。変更部分は後半の4つでそれぞれRangeの左（Left）、上（Top）、幅（Width）、高さ（Height）を指定してやればOKです。

使い方

　作ったプロシージャを呼び出すには以下のようにします。

Sub TestCode()
    MyShapeOval Range("B2")
    MyShapeOval Cells(3, "B")
End Sub

注意点

　実際の運用では、少々注意したい事があります。例えば、最後に追加したシェイプが選択状態になっていますし、TestCodeを２回実行すると、シェイプが重なった状態で追加されてしまいます。
　また、Excelの倍率表示が100%になっていない場合はセルの枠からはみ出てしまうようです。

　これらを改善してみましょう。

Sub TestCode2()
    'シェイプがある場合は全て削除
    If ActiveSheet.Shapes.Count > 0 Then
        ActiveSheet.Shapes.SelectAll
        Selection.ShapeRange.Delete
    End If
    
    'Excelの倍率表示を100%にする
    ActiveWindow.Zoom = 100

    MyShapeOval Range("B2")
    MyShapeOval Cells(3, "B")
    
    'セルを選択してシェイプの選択状態を解除する
    Cells(3, "B").Select
End Sub

　最初に既にシェイプがある場合は全て削除します。シェイプが無い状態で ActiveSheet.Shapes.SelectAll とするとエラーとなりますので、If文を使って予めシェイプの数を確かめています。

　次に Excel の倍率表示を100%にしています。倍率が100%になっていないとシェイプの位置がずれてしまうためです。

　続いてセル内にシェイプを配置した後、どこかのセルを選択して最後に追加したシェイプの選択状態を解除します。