【EXCEL】図形を自動配置する

やること

　図形の自動配置を、Copliotで作成。

参考

　図形の種類は、以下を参照するとよいかも。

【EXCEL】色のついた四角形を並べる(続き2) #Excel - Qiita

事例

1. B列に「丸」、「四角」、「丸四角」と記載し、実行
2. A列の同じ行に図形を配置
3. 図形間を直線コネクタで接続

　配置される図形は以下の通り。

Ｂ列	Ａ列
丸	msoShapeOval(楕円)
四角	msoShapeRectangle(四角形)
丸四角	msoShapeOval + msoShapeRectangle

shape自動配置.bas

'-------------------------------------------------------------------
' 関数: CreateShapesAndConnect
' 説明:
'   B列の指示（「丸」「四角」「丸四角」「なし」）に従って、
'   A列セルの中央に図形を描画する。
'
'   ・「丸」      → 楕円（msoShapeOval）
'   ・「四角」    → 四角形（msoShapeRectangle）
'   ・「丸四角」  → 四角(rect)に丸(circ)を重ねて表現（※グループ化しない）
'
'   図形同士は、作成順に直線コネクタで接続する。
'   コネクタ名は図形名に含まれる「行番号」を抽出し、
'   「線_行番号_次行番号」の形式で命名する。
'
' 引数:
'   なし（ActiveSheet を対象とする）
'
' 戻り値:
'   なし
'
' 使用例:
'   Call CreateShapesAndConnect
'
' 注意:
'   ・丸四角はグループ化しない（Excel仕様でコネクタ接続不可のため）
'   ・図形名は以下の規則で付与する：
'         丸      → 「丸_行番号」
'         四角    → 「四角_行番号」
'         丸四角  → rect:「丸四角_四角_行番号」, circ:「丸四角_丸_行番号」
'   ・コネクタ名は「線_行番号_次行番号」
'-------------------------------------------------------------------
Sub CreateShapesAndConnect()

    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim shp As Shape
    Dim i As Long, lastRow As Long
    Dim cell As Range
    Dim shapeList As Collection
    Set shapeList = New Collection

    '---------------------------------------------------------------
    ' 既存の図形をすべて削除
    '---------------------------------------------------------------
    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    '---------------------------------------------------------------
    ' B列の最終行を取得
    '---------------------------------------------------------------
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    '---------------------------------------------------------------
    ' 図形サイズ（固定）
    '---------------------------------------------------------------
    Const SHP_W As Single = 10
    Const SHP_H As Single = 10

    '---------------------------------------------------------------
    ' 行ループ：B列の指示に従って図形を作成
    '---------------------------------------------------------------
    For i = 1 To lastRow

        Set cell = ws.Cells(i, "B")
        Dim newShape As Shape
        Dim x As Single, y As Single

        ' A列セル中央の座標を計算
        x = ws.Cells(i, "A").Left + ws.Cells(i, "A").Width / 2 - SHP_W / 2
        y = ws.Cells(i, "A").Top + ws.Cells(i, "A").Height / 2 - SHP_H / 2

        Select Case Trim(cell.Value)

            '-------------------------------------------------------
            ' 丸（楕円）
            '-------------------------------------------------------
            Case "丸"
                Set newShape = ws.Shapes.AddShape(msoShapeOval, x, y, SHP_W, SHP_H)
                newShape.Name = "丸_" & i

                ' 色設定（白）
                newShape.Fill.ForeColor.RGB = RGB(255, 255, 255)
                newShape.Line.ForeColor.RGB = RGB(0, 0, 0)

            '-------------------------------------------------------
            ' 四角（長方形）
            '-------------------------------------------------------
            Case "四角"
                Set newShape = ws.Shapes.AddShape(msoShapeRectangle, x, y, SHP_W, SHP_H)
                newShape.Name = "四角_" & i

                ' 色設定（白）
                newShape.Fill.ForeColor.RGB = RGB(255, 255, 255)
                newShape.Line.ForeColor.RGB = RGB(0, 0, 0)

            '-------------------------------------------------------
            ' 丸四角（四角＋丸を重ねる。グループ化しない）
            '-------------------------------------------------------
            Case "丸四角"
                Dim rect As Shape, circ As Shape

                ' 四角
                Set rect = ws.Shapes.AddShape(msoShapeRectangle, x, y, SHP_W, SHP_H)
                rect.Name = "丸四角_四角_" & i
                rect.Fill.ForeColor.RGB = RGB(255, 255, 255)
                rect.Line.ForeColor.RGB = RGB(0, 0, 0)

                ' 丸
                Set circ = ws.Shapes.AddShape(msoShapeOval, _
                    x + SHP_W * 0.15, _
                    y + SHP_H * 0.15, _
                    SHP_W * 0.7, _
                    SHP_H * 0.7)
                circ.Name = "丸四角_丸_" & i
                circ.Fill.ForeColor.RGB = RGB(255, 255, 255)
                circ.Line.ForeColor.RGB = RGB(0, 0, 0)

                Set newShape = rect

            '-------------------------------------------------------
            ' なし（図形を作らない）
            '-------------------------------------------------------
            Case Else
                Set newShape = Nothing

        End Select

        ' 図形が作成された場合はリストに追加
        If Not newShape Is Nothing Then
            shapeList.Add newShape
        End If

    Next i

    '---------------------------------------------------------------
    ' 図形同士を直線コネクタで接続
    '---------------------------------------------------------------
    Dim j As Long
    For j = 1 To shapeList.Count - 1

        Dim s1 As Shape, s2 As Shape, conn As Shape
        Dim row1 As Long, row2 As Long

        Set s1 = shapeList(j)
        Set s2 = shapeList(j + 1)

        '-----------------------------------------------------------
        ' 図形名から行番号を抽出
        '   例： "丸_3" → Split → {"丸","3"} → 行番号 3
        '        "丸四角_四角_8" → Split → {"丸四角","四角","8"} → 行番号 8
        '-----------------------------------------------------------
        row1 = CLng(Split(s1.Name, "_")(UBound(Split(s1.Name, "_"))))
        row2 = CLng(Split(s2.Name, "_")(UBound(Split(s2.Name, "_"))))

        ' コネクタ（直線）
        Set conn = ws.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)

        ' コネクタ名を「線_行番号_次行番号」に設定
        conn.Name = "線_" & row1 & "_" & row2

        ' 図形の中心に接続
        conn.ConnectorFormat.BeginConnect s1, 1
        conn.ConnectorFormat.EndConnect s2, 1

        ' 線の太さ
        conn.Line.Weight = 1.5

        ' 図形より背面に移動
        conn.ZOrder msoSendToBack

    Next j

End Sub

結果