先日、既存の手順書がわかりにくくて、「フローチャートがないとコレ間違えるだろ」という会話があったのですが、作図に時間かけるのはアホらしい...

と思い、誰か作ってないか検索したところ、t-homさんのブレッドチャートなるものを発見！

これは素晴らしい！

と歓喜するや否や早速使用してみたたのですが、
「待てよ、もっともっと楽にできないか？」
と思い立ち、僭越ながらアップグレードさせて頂きました！

設計思想

t-homさんのものは先に図形を入れ、図形に対してテキストを入力するものでしたが、
今回のものは先にテキストを入れておき、後から図形を挿入する形をとりました。

また、図形内にテキストを収める形を取っ払い、テキストと図形は隣り合わせにして独立させるようにしました。

というのも、**手順を列挙する際は、作図に意識の流を遮られることなく、だだーっと書き殴りたい**からです。

使い方

作図モード起動

まずShift+Alt+cで作図モードを立ち上げます。

Offの間は通常のExcelとして使えるので邪魔になりません。

作図モードのOffもショートカットは同じです。

図形挿入→トグル切替

立ち上げたらAlt+cで選択中のセルのすぐ左に図形を挿入します。

そのままAlt+cを押すと、押す度に□→○→▽→...と図形が変わります。
先日のトグル切替が操作性よかったので今回も使いました。

ちなみに図形選択中なら作図モードがOffでも図形のタイプ変更はできます。

ちなみに図形のタイプはJIS Z 8206 工程図記号より基本図記号を抜粋しました。

図形とテキストを分離する発想も、現在資格取得に向けた勉強中に出てきたQC工程図から得られたので早速活用してみることにしました。

矢印でつなぐ

作図モードOnの状態で各図形をクリックすると、前にクリックした図形→新しくクリックした図形と矢印で繋ぎます。

こちらもほとんどt-homさんのものの焼き増しですが、2点改造させていただきました。

方位判定

t-homさんのものは前にクリックした図形と新しくクリックした図形の接続口が対象になるような設計でしたが、接続口1，接続口2と分けて、ケースバイケースのバリエーションを増やしました。
いきなり直線コネクタ

t-homさんのものはいったん全て鍵状コネクタでつないでおき、仕上げに直線コネクタに変換する、というものでしたが、方位判定時に縦や横の位置が同列のものはすぐに直線コネクタでつなぐように変更しました。

線形変更(直線/鍵状コネクタ)

コネクタをクリックすると直線/鍵状を切り替えます

繋いだ後で移動すると変更したくなる可能性があるので

線種変更(実線/破線)

図形(ブロックもコネクタも)選択状態でCtrl+Lで実線/破線を切り替えます

おそらく前述のQC工程図には登場しない記法ですが、僕が業務で使うので入れました(使い道は助走や逃げなどの予備動作や、主たる加工ではなさそうだなーと思うものとかを破線にするとかです)

コネクタの始点を新しく始めるには

Shift+Alt+cで作図モードをOffにするとコネクタの始点が白紙化されます。

再度Onにする再び図形の挿入とコネクタ生成ができるようになります。

仕上げ:テキストボックス生成

pptなどに転記することが想定されるので、仕上げにセル内容をテキストボックスに出力させます。

テキストボックスに変換したい範囲(Ctrl+クリックによる飛び飛び選択でもOK)を選択した状態で、最初に立ち上げた作図モード表示板を押してください。

アドインの作成方法

標準モジュールにコードをコピペする

Option Explicit

Dim x0 As Long
Dim y0 As Long
Dim h0 As Long
Dim dx As Long
Dim dy As Long
Dim myShape As Shape
Dim 今クリックしたShape As Shape
Dim 前にクリックしたShape As Shape
Dim 接続口1 As Direction
Dim 接続口2 As Direction
Dim 直線コネクタ As Boolean
Dim モード表示 As Shape

Enum Direction
  h = 15
  w = 15
  North = 1
  West = 2
  South = 3
  East = 4
End Enum

Enum ShpType
  b_数量検査□ = msoShapeRectangle
  a_加工〇 = msoShapeOval
  c_品質検査◇ = msoShapeDiamond
  d_貯蔵▽ = msoShapeFlowchartMerge
  e_滞留〇 = msoShapeFlowchartConnector
  f_運搬 = msoShapeFlowchartDelay
  鍵 = msoConnectorElbow
  直線 = msoConnectorStraight
End Enum

Function GetPos()
  With ActiveCell
    x0 = .Left
    y0 = .Top
    h0 = .Height
    dx = (ActiveCell.Offset(0, -1).Width + Direction.w) / 2 'すぐ左のセルの中央へ
    dy = (h0 - Direction.h) / 2
  End With
End Function

Sub MkShp1()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngYellow: lngYellow = RGB(255, 255, 0)

  Call MkShp(ShpType.a_加工〇, lngYellow, lngBlack)
End Sub

Sub MkShp(ShpType, RGB_Fill, RGB_Line)
  If モード表示 Is Nothing Then: Exit Sub
  GetPos
  Set myShape = ActiveSheet.Shapes.AddShape(ShpType, x0 - dx, y0 + dy, Direction.w, Direction.h)
  With myShape
    .Placement = xlMove
    .OnAction = "Click"
    .Select
  End With
  Call ShpColor(RGB_Fill, RGB_Line)
End Sub

Sub ShpToggle()
  On Error Resume Next
  Application.ScreenUpdating = False
  If TypeName(Selection) = "Range" Then
    Call MkShp1
  Else
    With Selection.ShapeRange
      Select Case .AutoShapeType
        Case Is = ShpType.e_滞留〇
           Call 運搬
        Case Is = ShpType.d_貯蔵▽
          Call 滞留〇
        Case Is = ShpType.c_品質検査◇
          Call 貯蔵▽
        Case Is = ShpType.b_数量検査□
          Call 品質検査◇
        Case Is = ShpType.a_加工〇
          Call 数量検査□
        Case Else
          Call 加工〇
      End Select
    End With
  End If
  Application.ScreenUpdating = True

End Sub

Sub ChgShp(ShpType, RGB_Fill, RGB_Line)
  Selection.ShapeRange.AutoShapeType = ShpType
  Call ShpColor(RGB_Fill, RGB_Line)
End Sub
Sub 加工〇()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngYellow: lngYellow = RGB(255, 255, 0)

  Call ChgShp(ShpType.a_加工〇, lngYellow, lngBlack)
End Sub
Sub 数量検査□()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngRed: lngRed = RGB(255, 0, 0)

  Call ChgShp(ShpType.b_数量検査□, lngRed, lngBlack)
End Sub
Sub 品質検査◇()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngGreen: lngGreen = RGB(0, 255, 0)
  Call ChgShp(ShpType.c_品質検査◇, lngGreen, lngBlack)
End Sub
Sub 貯蔵▽()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngBlue: lngBlue = RGB(0, 0, 255)
  Call ChgShp(ShpType.d_貯蔵▽, lngBlue, lngBlack)
End Sub
Sub 滞留〇()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngWhite: lngWhite = RGB(255, 255, 255)
  Call ChgShp(ShpType.e_滞留〇, lngWhite, lngBlack)
End Sub
Sub 運搬()
  Dim lngBlack: lngBlack = RGB(0, 0, 0)
  Dim lngPink: lngPink = RGB(255, 0, 255)
  Call ChgShp(ShpType.f_運搬, lngPink, lngBlack)
End Sub
Sub ShpColor(RGB_Fill, RGB_Line)  '
    With Selection.ShapeRange.Fill
      .Visible = msoTrue
      .ForeColor.RGB = RGB_Fill
      .Transparency = 0
      .Solid
    End With
    
    With Selection.ShapeRange.Line
      .Visible = msoTrue
      .ForeColor.RGB = RGB_Line
      .Transparency = 0
    End With
End Sub

Sub Click()
    Dim 今クリックしたShape As Shape: Set 今クリックしたShape _
        = ActiveSheet.Shapes(Application.Caller)
    今クリックしたShape.Select
    
    If モード表示 Is Nothing Then: Exit Sub
    If Not 前にクリックしたShape Is Nothing Then
      Call 方位判定(前にクリックしたShape, 今クリックしたShape)
      
      Dim コネクタ As Shape
      If 直線コネクタ = True Then
        Set コネクタ = ActiveSheet.Shapes.AddConnector(ShpType.直線, 1, 1, 20, 20)
      Else
        Set コネクタ = ActiveSheet.Shapes.AddConnector(ShpType.鍵, 1, 1, 20, 20)
      End If

      コネクタ.Line.EndArrowheadStyle = msoArrowheadOpen
      コネクタ.Line.Weight = 1.5
      コネクタ.Line.ForeColor.RGB = vbBlack
      コネクタ.OnAction = "線形変更"

      
      '〇は接続口が8つなので補正する
      If 前にクリックしたShape.AutoShapeType = ShpType.a_加工〇 Or _
        前にクリックしたShape.AutoShapeType = ShpType.e_滞留〇 Then
        接続口1 = 接続口1 * 2 - 1
      End If
      If 今クリックしたShape.AutoShapeType = ShpType.a_加工〇 Or _
        今クリックしたShape.AutoShapeType = ShpType.e_滞留〇 Then
        接続口2 = 接続口2 * 2 - 1
      End If
      
      コネクタ.ConnectorFormat.BeginConnect _
        ConnectedShape:=前にクリックしたShape, _
        ConnectionSite:=接続口1
          
      コネクタ.ConnectorFormat.EndConnect _
        ConnectedShape:=今クリックしたShape, _
        ConnectionSite:=接続口2
    End If
    Set 前にクリックしたShape = 今クリックしたShape
End Sub

Sub 方位判定(s1 As Shape, s2 As Shape) 'As Direction
    Dim s1横中央: s1横中央 = s1.Left + (s1.Width / 2)
    Dim s2横中央: s2横中央 = s2.Left + (s2.Width / 2)
    Dim 横の距離: 横の距離 = s2横中央 - s1横中央
    
    Dim s1縦中央: s1縦中央 = s1.Top + (s1.Height / 2)
    Dim s2縦中央: s2縦中央 = s2.Top + (s2.Height / 2)
    Dim 縦の距離: 縦の距離 = s2縦中央 - s1縦中央

    直線コネクタ = False
    If 縦の距離 > 0 Then
      接続口1 = South
      接続口2 = North
      If 横の距離 = 0 Then: 直線コネクタ = True
    Else
      If 横の距離 > 0 Then
        接続口1 = East
        接続口2 = West
        If 縦の距離 = 0 Then: 直線コネクタ = True
      ElseIf 横の距離 < 0 Then
        接続口1 = West
        接続口2 = East
        If 縦の距離 = 0 Then: 直線コネクタ = True
      Else
        接続口1 = East
        接続口2 = East
      End If
    End If
End Sub

Sub 作図モードOnOff()
  On Error Resume Next
  If モード表示 Is Nothing Then
    Call 作図モード表示
  Else
    Set 前にクリックしたShape = Nothing
    Set 今クリックしたShape = Nothing
    モード表示.Delete
    Set モード表示 = Nothing
  End If
End Sub

Sub 作図モード表示()
  Application.ScreenUpdating = False

  Dim xx: xx = 0 'ActiveCell.Offset(-1, 1).Left
  Dim yy: yy = ActiveCell.Top
'  Dim xx: xx = Application.Left
'  Dim yy: yy = Application.Top
  Set モード表示 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, xx, yy, 160, 60)
  
  Dim TextPart(5) As Variant
  TextPart(0) = "【工程図作成モードON中】"
  TextPart(1) = "・Alt+Cで図形挿入&形状変更"
  TextPart(2) = "・クリックでコネクタ接続"
  TextPart(3) = ""
  TextPart(4) = "仕上げ（TextBoxに変換）は"
  TextPart(5) = "変換したい範囲を選択してからこのボタンを押す"
  Dim TextMerge As String: TextMerge = TextPart(0)
  Dim i As Long
  For i = 1 To UBound(TextPart)
  TextMerge = TextMerge & vbCrLf & TextPart(i)
  Next i

  With モード表示
    .Line.Visible = msoFalse
      .OnAction = "仕上げ_TextBoxへ変換"
    With .TextFrame2
      .AutoSize = msoAutoSizeShapeToFitText
      .TextRange.Characters.Text = TextMerge
      .TextRange.ParagraphFormat.Alignment = msoAlignLeft
      '.TextRange.ParagraphFormat.Alignment = msoAlignCenter
      .VerticalAnchor = msoAnchorMiddle
    End With
    With .Fill
      .Visible = msoTrue
      .ForeColor.RGB = RGB(0, 176, 80)
      .Transparency = 0
      .Solid
    End With
  End With
  
  '見た目をボタンっぽくする
  With モード表示.ThreeD
    .BevelTopType = msoBevelCoolSlant
    .BevelTopInset = 13
    .BevelTopDepth = 6
    .PresetMaterial = msoMaterialDarkEdge
    .PresetLighting = msoLightRigChilly
    .BevelBottomDepth = 0
  End With
  Application.ScreenUpdating = True
End Sub

Sub 線形変更()
  On Error GoTo er:
  ActiveSheet.Shapes(Application.Caller).Select
  
    With Selection.ShapeRange.ConnectorFormat
      Select Case TypeName(Selection)
        Case Is = "Rectangle"
          .Type = 1
        Case Is = "Line"
          .Type = 2
      End Select
    End With

Exit Sub
er:
  Debug.Print Err.Number
End Sub

Sub 線種変更()
  If TypeName(Selection) = "Range" Then: Exit Sub
    With Selection.ShapeRange.Line
        Select Case .DashStyle
          Case Is = msoLineSolid
            .DashStyle = msoLineSysDash
'            GoTo NextL
          Case Is = msoLineSysDash
          .DashStyle = msoLineSolid
        End Select
      End With
End Sub

Sub 仕上げ_TextBoxへ変換()
  On Error Resume Next
  Application.ScreenUpdating = False
  If TypeName(Selection) <> "Range" Then: Exit Sub
  
  Dim r As Range
  Dim Txt As Shape
  
  For Each r In Selection
    If r = "" Then: GoTo Next_r
      Set Txt = ActiveSheet.Shapes.AddLabel _
        (msoTextOrientationHorizontal, r.Left, r.Top, r.Width, r.Height)
      Txt.TextFrame2.TextRange.Characters.Text = r.Value
      Txt.TextFrame2.WordWrap = msoFalse
Next_r:
  Next r
  
  モード表示.Delete
  Set モード表示 = Nothing

  Application.ScreenUpdating = True
End Sub

ブックモジュールにコードをコピペする

Option Explicit

Private Sub Workbook_Open()
  Application.OnKey "%c", "ShpToggle"
  Application.OnKey "%+c", "作図モードOnOff"
  Application.OnKey "^l", "線種変更"
End Sub

アドインとして保存する

ブック依存にすると、

いちいちそのブックを開かなきゃいけないとか
マクロ禁止の職場だと使えないとか

で不便なので、いつでも使えるようにアドインとしました。

(あくまでマクロは裏でしれーっとやるのがいいみたいです)

ただ、先日個人用マクロブックの方が便利じゃないかと申し上げましたが、挿入図形に付与したOnAction(図形をクリックするとマクロを実行する)でエラーが出るのを今回は解消でしなかったのでアドインとして保存することにしました。

アドインとして保存するには、

名前を付けて保存>アドイン(.xlam)
としてください。

保存したらリボンからアドインを有効化させたら終わりです。

アドインの作成方法について詳しく書かれた記事があったので転載させていただきます。

アレンジしたい方はこちら

いったん図形の色、線の太さ、ショートカットを僕個人の好みで作成しちゃってますが、ご自由に変更して頂いて結構です。

簡単ではありますが、図形タイプの順番やブロックのサイズ、ショートカット程度のアレンジ方法程度の変更方法を載せておきます。

図形タイプの順番を変えたい

Sub ShpToggle()
  On Error Resume Next
  Application.ScreenUpdating = False
  If TypeName(Selection) = "Range" Then
    Call MkShp1
  Else
    With Selection.ShapeRange
      Select Case .AutoShapeType
        Case Is = ShpType.e_滞留〇
           Call 運搬
        Case Is = ShpType.d_貯蔵▽
          Call 滞留〇
        Case Is = ShpType.c_品質検査◇
          Call 貯蔵▽
        Case Is = ShpType.b_数量検査□
          Call 品質検査◇
        Case Is = ShpType.a_加工〇
          Call 数量検査□
        Case Else
          Call 加工〇
      End Select
    End With
  End If
  Application.ScreenUpdating = True

End Sub

の中のSelect文の中の順番を変えるだけです。

Case Is = ○○で「今のタイプ」を判別して

Call ●●で変更するタイプを指定しています。

ここの名称をコピペで入れ替えれば順番が変わります。

注:上の行で変更したタイプがそれより下の行で判別文に引っかかるので、実操作で1→2→3としたい時は

3

2

1

と逆順にしてください。

挿入ブロックのデフォルトサイズを変えたい

いったん縦横15としていますが、標準モジュールのこちらを変更していただければすぐに変更できます。

Enum Direction
  h = 15
  w = 15
End Enum

ショートカット割り当てを変えたい

現在、僕が勝手に割り当てたショートカットはこんな感じですが、

キー	アクション
Ctrl+Shift+C	作図モードOn/Off
Ctrl+C	ブロック生成、タイプ変更
Ctrl+L	線種変更

使いにくいんじゃボゲェ！という方は、ブックモジュール内のApplication.Onkey "●●","マクロ名"の●●を変えてください

Ctrlは^とかShiftは+とかの変換表はこちらです。

以上です。