VBAの悩みはVBAerにきけ_地獄絵図編~フローチャート作成VBA-後編~

続きです。

不要な列を削除して、パラメータシートの[アクター表の再定義]をクリックします。

そうすると、先ほど削除した列の項目は削除されて表がリフレッシュされました。この状態で新規にフローを作成すると適切な場所におさまっています。

3.VBAの解説(ソース解説はここにて)

VBAの説明、ここにて説明するつもりだったんですけど、
もう疲れたので後日加筆します。

Option Explicit

Type アクター表
    アクター As Variant
    セル番地 As Variant
    開始セル列数 As Variant
    End Type

Type フロー図
    Fromアクター As Variant
    fromオブジェクト As Variant
    From内容 As Variant
    矢印 As Variant
    Toアクター As Variant
    toオブジェクト As Variant
    To内容 As Variant

End Type

Type フローオブジェクト
'作成後の名称はアクター&内容で管理
    アクター As Variant
    オブジェクト As Shape
    内容 As Variant
    参照 As Shape
End Type

Enum eFromオブジェクト
    Fromアクター = 1
    fromオブジェクト = 2
    From内容 = 3
End Enum

Enum toオブジェクト
    Toアクター = 5
    toオブジェクト = 6
    To内容 = 7
End Enum

Enum eアクター表
    アクター = 1
    セル番地 = 2
    開始セル列 = 3
End Enum
Sub オブジェクト名変更()

    'エラー定義の設定
    '@error_no:999
    '@内容:オブジェクトを選択していない場合、エラーを発生
    '@解消方法:オブジェクトを選択して再実行
    On Error GoTo error_Label
    If VarType(Selection) <> vbObject Then
        Err.Raise Number:=999, Description:="オブジェクトを選択して再実行してください。"
    End If

    '変数定義
    Dim tbl As ListObject
    Set tbl = ThisWorkbook.Sheets("オブジェクト").ListObjects("オブジェクト名一覧")

    Call オブジェクトの名称編集
    Call リストの行に追加(tbl, Selection.name)

error_Label:
    If Err.Number <> 0 Then
         MsgBox Prompt:=Err.Number & vbCrLf & Err.Description
    End If
    End Sub

Function オブジェクトの名称編集()
'既存の名称をデフォルトにします。
    Selection.name = InputBox(Prompt:="オブジェクトの名前を編集してください", _
                              Default:=Selection.name)
End Function

Sub アクターの領域設定()
    '変数定義
    Dim tbl As ListObject
    Set tbl = ThisWorkbook.Sheets("パラメータ").ListObjects("アクター表")

    'アクター表の内容をクリア
    Call 表の内容をクリア(tbl)

    Dim wrow As Long
    Dim wcol As Long

    Dim wrange As Range

    wrow = Range("アクターの開始行").Value
    wcol = Range("アクターの開始列").Value

    Dim ws As Worksheet
    Dim アクター表 As アクター表

    Set ws = ThisWorkbook.Sheets("作成オブジェクト")

    Set wrange = ws.Cells(wrow, wcol)


    '条件：アクターが終了した際にループを抜けます。
    Do While wrange.Value <> ""
    'アクター表の内容を定義
       アクター表.アクター = wrange.Value
       '結合セルの開始セルのみを取得するためにOffset(0,0)をつけています。
       アクター表.セル番地 = wrange.Offset(0, 0).address(RowAbsolute:=False, ColumnAbsolute:=False)
       アクター表.開始セル列数 = wrange.Offset(0, 0).Column

    'アクター表の行を追加
       Call アクターテーブルの行に追加(アクター表)

       Set wrange = wrange.Offset(0, 1)
    Loop


End Sub

Sub フロー図作成()
    '変数定義
    Dim tbl As ListObject
    Dim shp As Shape
    Set tbl = ThisWorkbook.Sheets("パラメータ").ListObjects("フロー図")

    Dim obj_from As フローオブジェクト
    Dim obj_to   As フローオブジェクト

    Dim i
    For i = 1 To tbl.ListRows.Count

        Call オブジェクトfromの定義(tbl.ListRows(i), obj_from)
        Call オブジェクトtoの定義(tbl.ListRows(i), obj_to)
        Call オブジェクトの追加(obj_from.オブジェクト, obj_from.内容, obj_from.アクター)
        Call オブジェクトの追加(obj_to.オブジェクト, obj_to.内容, obj_to.アクター)

    Next i
        Call オブジェクトのコネクタ結合(tbl)
        Call オブジェクトの配置(tbl)

    MsgBox "フロー図の作成完了しました。"

End Sub

Function オブジェクトのコネクタ結合(tbl As ListObject)

    Dim i
    Dim tmp
    Dim obj_from As フローオブジェクト
    Dim obj_to As フローオブジェクト
    Dim connect As Shape

    For i = 1 To tbl.ListRows.Count

        Call オブジェクトfromの定義(tbl.ListRows(i), obj_from)
        Call オブジェクトtoの定義(tbl.ListRows(i), obj_to)

        Dim tmp_con As Shape
        ThisWorkbook.Sheets("オブジェクト").Shapes("→").PickUp


        Set connect = ThisWorkbook.Sheets("作成オブジェクト").Shapes.AddConnector(msoConnectorElbow, 1, 1, 1, 1)
        With connect
            .ConnectorFormat.BeginConnect obj_from.参照, 3
            .ConnectorFormat.EndConnect obj_to.参照, 1
            .Apply
        End With

    Next

End Function


Function オブジェクトの配置(tbl As ListObject)

    '前回のフローからコネクタが接続しているか確認します。
    Dim obj_from As フローオブジェクト
    Dim obj_to   As フローオブジェクト
    Dim tmp      As フローオブジェクト
    Dim row
    Dim i

    row = ThisWorkbook.Sheets("パラメータ").Range("オブジェクトの開始行").Value
    For i = 1 To tbl.ListRows.Count
        Call オブジェクトfromの定義(tbl.ListRows(i), obj_from)
        Call オブジェクトtoの定義(tbl.ListRows(i), obj_to)

        Call オブジェクトのセル配置(obj_from, obj_to, tmp, row)

        Call オブジェクトのシャドウコピー(obj_to, tmp)

    Next

End Function

Function オブジェクトのセル配置(obj_from As フローオブジェクト, obj_to As フローオブジェクト, tmp As フローオブジェクト, ByRef row)

    Dim ws
    Dim w_row
    Dim w_col
    Dim w_rng

    Call アクター定義(obj_from, w_col)
    Set ws = ThisWorkbook.Sheets("作成オブジェクト")
    w_row = row
    If tmp.アクター & tmp.内容 <> obj_from.アクター & obj_from.内容 Then
        Call アクター定義(obj_from, w_col)
        With obj_from.参照
            .Top = ws.Cells(w_row, w_col).Top
            .Left = ws.Cells(w_row, w_col).Left
        End With
        w_row = obj_from.参照.BottomRightCell.row
        w_row = w_row + ThisWorkbook.Sheets("パラメータ").Range("オブジェクトの間隔").Value
    End If

    Call アクター定義(obj_to, w_col)

        With obj_to.参照
            .Top = ws.Cells(w_row, w_col).Top
            .Left = ws.Cells(w_row, w_col).Left
        End With

    w_row = obj_to.参照.BottomRightCell.row
    row = w_row + ThisWorkbook.Sheets("パラメータ").Range("オブジェクトの間隔").Value
End Function

Function 表の内容をクリア(tbl As ListObject)

    Dim row
    For row = tbl.ListRows.Count To 1 Step -1
        tbl.ListRows(row).Delete
    Next
End Function


Function リストの行に追加(tbllist As ListObject, x)

    Dim row As ListRow
    Set row = tbllist.ListRows.Add
    row.Range.Value = x
End Function


Function アクターテーブルの行に追加(x As アクター表)
    Dim tbllist As ListObject
    Set tbllist = ThisWorkbook.Sheets("パラメータ").ListObjects("アクター表")
    Dim row As ListRow
    With tbllist.ListRows.Add
      .Range(1).Value = x.アクター
      .Range(2).Value = x.セル番地
      .Range(3).Value = x.開始セル列数
    End With
End Function

Function オブジェクトfromの定義(row As ListRow, ByRef obj_from As フローオブジェクト)

        obj_from.アクター = row.Range(eFromオブジェクト.Fromアクター)
        obj_from.内容 = row.Range(eFromオブジェクト.From内容)

        Set obj_from.オブジェクト = ThisWorkbook.Sheets("オブジェクト").Shapes(row.Range(eFromオブジェクト.fromオブジェクト))

        Dim shp As Shape
        For Each shp In ThisWorkbook.Sheets("作成オブジェクト").Shapes
            If shp.name = obj_from.アクター & obj_from.内容 Then
                Set obj_from.参照 = ThisWorkbook.Sheets("作成オブジェクト").Shapes(obj_from.アクター & obj_from.内容)
            End If
        Next
End Function

Function オブジェクトtoの定義(row As ListRow, ByRef obj_to As フローオブジェクト)
        obj_to.アクター = row.Range(toオブジェクト.Toアクター)
        obj_to.内容 = row.Range(toオブジェクト.To内容)

        Set obj_to.オブジェクト = ThisWorkbook.Sheets("オブジェクト").Shapes(row.Range(toオブジェクト.toオブジェクト))

        Dim shp As Shape
        For Each shp In ThisWorkbook.Sheets("作成オブジェクト").Shapes
            If shp.name = obj_to.アクター & obj_to.内容 Then
                Set obj_to.参照 = ThisWorkbook.Sheets("作成オブジェクト").Shapes(obj_to.アクター & obj_to.内容)
            End If
        Next

End Function

Function オブジェクトのシャドウコピー(obj_to As フローオブジェクト, tmp As フローオブジェクト)
        tmp.アクター = obj_to.アクター
        tmp.内容 = obj_to.内容
        Set tmp.オブジェクト = obj_to.オブジェクト
        Set tmp.参照 = obj_to.参照

End Function

Function アクター定義(obj As フローオブジェクト, ByRef col)
    Dim tbl As ListObject
    Set tbl = ThisWorkbook.Sheets("パラメータ").ListObjects("アクター表")

    Dim row As ListRow
    For Each row In tbl.ListRows
        If row.Range(eアクター表.アクター) = obj.アクター Then
            col = row.Range(eアクター表.開始セル列)
        End If
    Next
End Function

Function オブジェクトの追加(shp As Shape, context, address)

    Dim tmp As Shape
    Dim name As Shape
    '名称管理で重複していないかチェック
    '重複している場合、追加せずに次の処理に進む
    For Each name In ThisWorkbook.Sheets("作成オブジェクト").Shapes
        If name.name = address & context Then Exit Function
    Next

    Set tmp = shp.Duplicate
    If context <> "" Then
      tmp.name = address & context
    End If

    tmp.TextFrame2.TextRange.Text = context

    tmp.Cut
    ThisWorkbook.Sheets("作成オブジェクト").Paste

End Function