図形の入った資料を高速で書く試み

はじめに

最近現場にて図形の入った資料（処理フロー）を書く機会があったのですが、自作のマクロや現場のメンバーが作ったツールを使って素早く書くことができました。
本記事ではどのようなやり方をしていたかと、自作のマクロの一部を公開します

使用した自作マクロ及びツールの説明

処理フロー作成で使ったツールの簡単に説明します。

①図形作成ツール

　入力欄（複数入力可）に入力した文字列を持つ図形を作成するツール。

②矢印付与マクロ

　選択した図形を矢印でつなぐマクロ。
　１つ目に選択した図形から２つ目以降に選択した図形がつながる。
　ショートカットに割り当てるとよし。

③図形テキスト置換マクロ

　シート上のすべての図形で、文字列を一括で置換するマクロ。

処理フロー作成の流れ

1．Excel上で表形式の図形テキストを書き並べる
　この表が実質的な内容となります。

2．図形テキスト置換マクロで表の図形要素をすべて図形化する
　図形の形式を変える場合は一括で図形の変更を行います。

3．作成資料にコピペ＆位置調整を行う
　位置の調整はExcel標準機能の「図形の書式-配置」にあるものを使うと速いです。

4．矢印付与マクロで図形を適宜矢印でつなげる
　いちいち矢印を図形の挿入からやる必要がないため、スムーズに矢印を付与できます。

5．複数図形のテキスト修正は図形テキスト置換マクロで一括置換する
　図形テキストは手作業で1つ1つ変えるのは大変ですが、マクロで一括で変えられるとかなり効率的に作業ができます。

所感

ツールとマクロ自体はそれほど複雑なものではありませんが、痒い所に手が届くような便利さがあります。
これでもかなり効率的に作業することができましたが、資料に修正が多く入ると表形式の図形テキストと実際の図形テキストが乖離してしまうので、図形テキストから表形式の図形テキストに気軽に変換することができたらさらに便利に作業できるかなと思いました。

マクロの共有

矢印付与マクロ

ConnectSelectedShapes

' 利用する関数
Sub ConnectSelectedShapes()
    If Not VarType(Selection) = vbObject Then End
    Dim i  As Long
    For i = 2 To Selection.ShapeRange.Count
        Call ConnectTwoShapes(Selection.ShapeRange(1), Selection.ShapeRange(i))
    Next
End Sub
'補助関数
Sub ConnectTwoShapes(ByRef src As Shape, ByRef dst As Shape)
    On Error GoTo ConnectTwoRectanglesError
    Dim line As Shape
    Set line = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 100)
    line.line.EndArrowheadStyle = msoArrowheadTriangle
    line.ConnectorFormat.BeginConnect src, 4
    line.ConnectorFormat.EndConnect dst, 2
    line.RerouteConnections
    Exit Sub
ConnectTwoRectanglesError:
    line.Delete
End Sub

図形テキスト置換マクロ

objTextReplace

Sub objTextReplace()
    Dim before, after, msg
    Application.ScreenUpdating = False
    before = InputBox("置換前文字列を入力してください" & vbCrLf & "※部分一致", "Before")
    If StrPtr(before) = 0 Then Exit Sub
    after = InputBox("置換後文字列を入力してください" & vbCrLf & "※部分一致", "After")
    If StrPtr(after) = 0 Then Exit Sub
    msg = "以下の置換条件で実行します。" & vbCrLf & _
          "置換前文字列：" & before & vbCrLf & _
          "置換後文字列：" & after
    If MsgBox(msg, vbQuestion + vbYesNo + vbDefaultButton2, "質問") <> vbYes Then Exit Sub
    
    On Error GoTo replaceError
    Dim i, cnt: cnt = 0
    For i = 1 To ActiveSheet.DrawingObjects.Count
        With ActiveSheet.DrawingObjects(i)
            If .Caption Like "*" & before & "*" Then
                .Caption = Replace(.Caption, before, after)
                cnt = cnt + 1
            End If
        End With
replaceError:
        Resume continue
continue:
    Next
    Application.ScreenUpdating = True
    
    MsgBox cnt & "件の置換が完了しました"
End Sub