セルと同じサイズでフローチャートを作成する

昨日は、セルを選択してオートシェイプが全解除された場合、ユーザーフォームのリストボックスについても全項目を選択解除させてみました。

infoment.hatenablog.com

今日は、オートシェイプのサイズをセルに合わせて作成することに挑戦です。

今日やりたいこと

もともと一連のフローチャート作成ツールを作成する切っ掛けとなった方からは、以下の希望が寄せられていました。

セルと同じサイズのオートシェイプを作成し、セルにピタリと合わせて配置したい。

そこで今日は、適当に配置していたオートシェイプの配置方法を変更します。

必要なこと

1. 行と列のサイズを、ある程度の幅に広げておく
2. オートシェイプを、一行飛ばしあるいは一列飛ばしで、セルサイズに合わせて配置する。

１．行と列のサイズを、ある程度の幅に広げておく

今回は、以下の通り設定しました。

• 行幅 80（106ピクセル）
• 列幅 25（206ピクセル）

この辺りは、お好みに合わせて設定可能です。

２．オートシェイプを、一行飛ばしあるいは一列飛ばしで、セルサイズに合わせて配置する。

今回は、下記手順で行うことにしました。

1. シートをコピーする。
2. セルの記載内容を削除する。
3. Ａ１セルから順に、一行飛ばし或いは一列飛ばしで、セルサイズに合わせて配置する。

ｉ＝１，２，３と数が増えるごとに、１，３，５と変化させる場合、
２×ｉ－１とすればＯＫです。

これらをまとめた結果は、以下の通りです。

【標準モジュール】

Public Sub MakeBlock()
     
    Dim seq As Variant
        seq = Selection
        
        If IsArray(seq) = False Then
            MsgBox "空白セルが一つだけ選択されているため、処理を中断します。"
            Exit Sub
        End If
        ' ↓↓今回の追加個所↓↓
        ' シートをコピーしたうえで、不要な情報を削除しています。
        ActiveSheet.Copy After:=ActiveSheet
        ActiveSheet.UsedRange.Clear
        ' 開始セルをＡ１としています。
        Dim StartCell As Range
        Set StartCell = Range("A1")
        ' ↑↑今回の追加個所↑↑
        
    ReDim SFC(1 To UBound(seq, 1), 1 To UBound(seq, 2))
    Dim i As Long, j As Long
        For j = 1 To UBound(seq, 2)
            For i = 1 To UBound(seq, 1)
                If seq(i, j) <> "" Then
                    Set SFC(i, j) = New ShapeClass
                    ' ↓↓今回の変更箇所↓↓
                    ' 配置したいセルの位置情報とサイズ情報を元に、
                    ' オートシェイプを描画しています。
                    Set SFC(i, j).myShape = ActiveSheet.Shapes.AddShape(msoShapeFlowchartProcess, _
                                                                        StartCell.Cells(2 * i - 1, 2 * j - 1).Left, _
                                                                        StartCell.Cells(2 * i - 1, 2 * j - 1).Top, _
                                                                        StartCell.Cells(2 * i - 1, 2 * j - 1).Width, _
                                                                        StartCell.Cells(2 * i - 1, 2 * j - 1).Height)
                    ' ↑↑今回の変更箇所↑↑
                        SFC(i, j).myShape.TextFrame2.TextRange.Characters.Text = seq(i, j)
                        SFC(i, j).myShape.Name = SFC(i, j).myShape.Name & "_" & i & "_" & j
                        SFC(i, j).myShape.OnAction = "SelectShape"
                        SFC(i, j).SetFormat
                End If
            Next
        Next
        
End Sub

結果

セルに合わせて、フローチャートを作成できるようになりました。

次回に続きます。

参考まで。