エクセルシートからチャート

はじめに

エクセルでチャート（フローチャート）を作るとき、図形を挿入して、文字を入力して、矢印で接続する。
を、繰り返します。

エクセルのセル情報から、半自動的にできるとうれしい。Mermaidみたいに。

誰かが作っていそうな気がしますが、検索できませんでした。

とりあえずやってみた

文字セルは、セルの文字を含んだ四角形に変換
<--, -->, ^||, ||v は矢印に変換
四角形及び矢印はの大きさは、セルと同じ大きさ

例

1. 次のようなエクセルを作成
   

2. 範囲を選択
   

3. makeShapes マクロ実行
   
   全体を選択して 移動します。
   図形と線はつながっていません。

エラー処理していないので、とりあえずのコード

Option Explicit

Public Sub makeShapes()
    Dim rng As Range
    Set rng = Selection

    Dim i As Long
    Dim j As Long
    Dim cellText As String
    Dim isAct As Boolean

    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            isAct = True
            If rng.Cells(i, j).MergeCells Then
                If rng.Cells(i, j) <> rng.Cells(i, j).MergeArea.Cells(1, 1) Then
                    isAct = False
                End If
            End If

            If isAct Then
                cellText = rng.Cells(i, j).Text
                If cellText <> "" Then
                    Select Case cellText
                        Case "<--", "-->", "^||", "||v"
                            makeArrow rng.Cells(i, j), cellText
                        Case Else
                            makeShape rng.Cells(i, j)
                    End Select
                End If
            End If
        Next
    Next
End Sub

Private Sub makeShape(rng As Range)

    Dim cellText As String
    cellText = rng.Cells(1, 1).Text

    Dim Left As Single
    Dim Top As Single
    Dim Width As Single
    Dim Height As Single

    Left = rng.MergeArea.Left
    Top = rng.MergeArea.Top
    Width = rng.MergeArea.Width
    Height = rng.MergeArea.Height

    Dim tmpShape As Shape
    Set tmpShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Left, Top, Width, Height)
    tmpShape.TextFrame2.TextRange.Characters.Text = cellText

    tmpShape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    tmpShape.TextFrame2.VerticalAnchor = msoAnchorMiddle
End Sub

Private Sub makeArrow(rng As Range, arrowType As String)

    Dim cellText As String
    cellText = rng.Cells(1, 1).Text

    Dim Left As Single
    Dim Top As Single
    Dim Width As Single
    Dim Height As Single

    Left = rng.MergeArea.Left
    Top = rng.MergeArea.Top
    Width = rng.MergeArea.Width
    Height = rng.MergeArea.Height

    Dim startX As Single
    Dim startY As Single
    Dim endX As Single
    Dim endY As Single

    Dim startStyle As MsoArrowheadStyle
    Dim endStyle As MsoArrowheadStyle

    startStyle = msoArrowheadNone
    endStyle = msoArrowheadNone

    Select Case arrowType
        Case "<--"
            startX = Left
            endX = Left + Width
            startY = Top + Height * 0.5
            endY = Top + Height * 0.5
            startStyle = msoArrowheadTriangle
        Case "-->"
            startX = Left
            endX = Left + Width
            startY = Top + Height * 0.5
            endY = Top + Height * 0.5
            endStyle = msoArrowheadTriangle

        Case "^||"
            startX = Left + Width * 0.5
            endX = Left + Width * 0.5
            startY = Top
            endY = Top + Height
            startStyle = msoArrowheadTriangle

        Case "||v"
            startX = Left + Width * 0.5
            endX = Left + Width * 0.5
            startY = Top
            endY = Top + Height
            endStyle = msoArrowheadTriangle
    End Select



    Dim tmpShape As Shape
    Set tmpShape = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, startX, startY, endX, endY)
    tmpShape.Line.EndArrowheadStyle = endStyle
    tmpShape.Line.BeginArrowheadStyle = startStyle
End Sub