表の下にオブジェクトを挿入するマクロについて（再投稿）

あ###前提・実現したいこと
画像のように、表の下に右のような図を挿入するマクロを作成したいです。
表からL1がA008LV2がA002、A003というように順に図と矢印を挿入するマクロを途中まで作成したのですが、期限に間に合わないので少しでもいいですのでアドバイスを頂ければと思います。
初心者で申し訳ありません。
宜しくお願い致します。

###該当のソースコード
未完成で申し訳ありません・・・下記が途中までのソースコードです・

' プロジェクトネットワーク図作成マクロ
Sub test()
' 変数宣言
Dim RoopCount As Long ' ループカウンタ
Dim ID_Count As Long ' ループカウンタ
Dim LastRow As Long ' ID最終行取得
Dim TestID As String ' ID取得

With Worksheets("Sheet1")

' B列が空欄であればfor文を抜ける
RoopCount = .Cells(Rows.Count, "B").End(xlUp).Row
For ID_Count = 4 To RoopCount

' B列にIDが記入されていれば処理を行う
If .Cells(ID_Count, 4).Value <> "" Then
' 表のB列試験ID最終行を取得
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row

' B列試験ID取得
TestID = .Cells(ID_Count, 4).Value

' オブジェクト追加
Set myDocument = Worksheets(1)
myDocument.Shapes.AddShape msoShapeRoundedRectangle, 50, 50, 88, 37

' シェイプを選択
ActiveSheet.Shapes(1).Select

'塗りつぶしの設定

   ????

End With

'文字列を入れる
Selection.Characters.Text = TestID 'A列のみ

End If

Next
End With
End Sub
コード

ynakano

2016/10/17 23:28

withとend withの対応関係がおかしくないですか？

ttyp03

2016/10/18 00:33

仕様が曖昧じゃないですか？なんでA002からA006には線がないのですか？どうしてA003はA006に線がないのですか？

行動規範の内容に同意します

回答3件

マクロの記録という機能で解決できました！ありがとうございました。

投稿2016/10/20 02:29

Arisa

総合スコア10

ベストアンサー

現状出来ている部分を少し扱いやすいよう修正し、コード中で????となっていた色変更部分を補完しました。


Enum COL
    ID = 2
    LV = 3
End Enum

' プロジェクトネットワーク図作成マクロ
Sub test()
    ' 変数宣言
    Dim RoopCount As Long ' ループカウンタ
    Dim ID_Count As Long ' ループカウンタ
    Dim LastRow As Long ' ID最終行取得
    Dim TestID As String ' ID取得
    
    With Worksheets("Sheet2")
        
        ' B列が空欄であればfor文を抜ける ⇒ 正しくは、B列の最終データ行までループ処理を行う
        RoopCount = .Cells(Rows.Count, COL.ID).End(xlUp).Row
        
        Dim clShapes As New Collection
        
        For ID_Count = 4 To RoopCount
            
            ' B列にIDが記入されていれば処理を行う
            If .Cells(ID_Count, COL.ID).Value <> "" Then
                ' 表のB列試験ID最終行を取得
                LastRow = .Cells(Rows.Count, COL.ID).End(xlUp).Row
                
                ' B列試験ID取得
                TestID = .Cells(ID_Count, COL.ID).Value
                
                ' オブジェクト追加
                'Set myDocument = Worksheets(2)
                'myDocument.Shapes.AddShape msoShapeRoundedRectangle, 50, 50, 88, 37
                '' シェイプを選択
                'ActiveSheet.Shapes(1).Select
                Dim shp As Shape
                Set shp = .Shapes.AddShape(msoShapeRoundedRectangle, 50, 50, 88, 37)
                
                '文字色の設定
                shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbBlack
                shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
                shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
                
                '罫線色の設定
                shp.Line.ForeColor.RGB = vbGreen    'vbGreenのような予約語でなく、RGB(0,255,0)という記述も可能です
                
                '塗りつぶしの設定
                shp.Fill.ForeColor.RGB = vbWhite
                
                '文字列を入れる
                'Selection.Characters.Text = TestID 'A列のみ
                shp.TextEffect.Text = TestID 'A列のみ
                
                '作成したシェイプをコレクションに追加しておく
                clShapes.Add shp, TestID
                
            End If
        Next
        
        '矢印を引く（ルールはわからないのでとりあえず"A001"から"A002"への引き方）
        Dim shp1 As Shape
        Dim shp2 As Shape
        
        Dim shpAllow As Shape
        
        Set shp1 = clShapes("A001")
        Set shp2 = clShapes("A002")
        
        '矢印の作成
        Set shpAllow = .Shapes.AddConnector(msoConnectorStraight, 353.25, 51.25, 384.5, 88)
        shpAllow.Line.EndArrowheadStyle = msoArrowheadOpen
        
        '始点の設定（A001の右辺）
        shpAllow.ConnectorFormat.BeginConnect shp1, 4
        '終点の設定（A002の左辺）
        shpAllow.ConnectorFormat.EndConnect shp2, 2
        
    End With
    
End Sub

他にも内容に応じて配置を変更したり、矢印を設置する必要があるのだと思いますが、配置のルールも提示いただいていないようですし、あとは自力で頑張ってみてください。
（矢印の引き方はサンプルとして１本だけ記述しました。）
（配置の方法は他の方からサンプルコードが提示されているようですので、組み合わせてご利用ください。）

「開発」メニューの中にある「マクロの記録」で操作内容をマクロ化すると開発がはかどる場合があります。

今回でいうと、シェイプを作成してから「マクロの記録」を開始し、シェイプの色や位置などを変更して記録終了すると、シェイプの色や位置を変更した操作を自動的にVBAで作成してくれます。
（一度にたくさんの操作をしたり余分な操作をしたりすると、目的の命令がどこにあるのかわかりにくくなるので、細かい単位で記録することをお勧めします。）

参考になれば幸いです。

投稿2016/10/18 01:47

jawa

総合スコア3013

Arisa

2016/10/20 02:28

非常に参考になりました。マクロの記録という機能初めて知りました・・・解決できました！ありがとうございました。

行動規範の内容に同意します

お急ぎということですので、ある程度まで作成しました。

VBA
1' プロジェクトネットワーク図作成マクロ
2Sub test()
3' 変数宣言
4Dim RoopCount As Long ' ループカウンタ
5Dim ID_Count As Long ' ループカウンタ
6Dim LastRow As Long ' ID最終行取得
7Dim TestID As String ' ID取得
8Dim myDocument As Worksheet
9 'LV1～LV4用のcollection
10Dim Coll1 As New Collection
11Dim Coll2 As New Collection
12Dim Coll3 As New Collection
13Dim Coll4 As New Collection
14Dim i, j, k, l, m As Integer
15Dim jn, kn, ln, mn As Integer
16Dim LV1(10), LV2(10), LV3(10), LV4(10) As String
17Dim LV1Row(10), LV2Row(10), LV3Row(10), LV4Row(10) As Integer
18
19i = 1
20j = 0
21k = 0
22l = 0
23m = 0
24
25With Worksheets("Sheet1")
26    
27' B列が空欄であればfor文を抜ける
28RoopCount = .Cells(Rows.Count, "B").End(xlUp).Row
29For ID_Count = 3 To RoopCount
30    
31' B列にIDが記入されていれば処理を行う
32If .Cells(ID_Count, 2).Value <> "" Then
33' 表のC列を確認し、LVに応じて各LVの配列にデータを振り分け、また、その時の行数を取得しておく。
34LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
35    Select Case .Cells(ID_Count, 3)
36    Case "LV1"
37    LV1(j) = .Cells(ID_Count, 2)
38    LV1Row(j) = ID_Count
39    j = j + 1
40    Case "LV2"
41    LV2(k) = .Cells(ID_Count, 2)
42    LV2Row(k) = ID_Count
43    k = k + 1
44    Case "LV3"
45    LV3(l) = .Cells(ID_Count, 2)
46    LV3Row(l) = ID_Count
47    l = l + 1
48    Case "LV4"
49    LV4(m) = .Cells(ID_Count, 2)
50    LV4Row(m) = ID_Count
51    m = m + 1
52    End Select
53    End If
54Next
55
56'各レベルのカウント数
57jn = j
58kn = k
59ln = l
60mn = m
61
62' オブジェクト追加
63Set myDocument = Worksheets(1)
64
65For j = 1 To jn
66    TestID = .Cells(LV1Row(j - 1), 2).Value
67myDocument.Shapes.AddShape msoShapeRoundedRectangle, 50, 50 + i * 50, 88, 37
68' シェイプを選択
69Coll1.Add ActiveSheet.Shapes.Item(j)
70'塗りつぶしの設定
71Coll1.Item(j).Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
72Coll1.Item(j).Line.ForeColor.RGB = RGB(0, 0, 0)
73'文字列を入れる
74Coll1.Item(j).DrawingObject.Text = TestID
75Coll1.Item(j).DrawingObject.Font.Color = 0
76i = i + 1
77Next
78
79i = 0
80For k = 1 To kn
81    TestID = .Cells(LV2Row(k - 1), 2).Value
82myDocument.Shapes.AddShape msoShapeRoundedRectangle, 150, 50 + i * 50, 88, 37
83' シェイプを選択
84Coll2.Add ActiveSheet.Shapes.Item(jn + k)
85'塗りつぶしの設定
86Coll2.Item(k).Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
87Coll2.Item(k).Line.ForeColor.RGB = RGB(0, 0, 0)
88'文字列を入れる
89Coll2.Item(k).DrawingObject.Text = TestID
90Coll2.Item(k).DrawingObject.Font.Color = 0
91i = i + 1
92Next
93
94i = 0
95
96For l = 1 To ln
97        TestID = .Cells(LV3Row(l - 1), 2).Value
98myDocument.Shapes.AddShape msoShapeRoundedRectangle, 250, 50 + i * 50, 88, 37
99' シェイプを選択
100Coll3.Add ActiveSheet.Shapes.Item(jn + kn + l)
101'塗りつぶしの設定
102Coll3.Item(l).Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
103Coll3.Item(l).Line.ForeColor.RGB = RGB(0, 0, 0)
104'文字列を入れる
105Coll3.Item(l).DrawingObject.Text = TestID
106Coll3.Item(l).DrawingObject.Font.Color = 0
107i = i + 1
108Next
109
110i = 0
111
112For m = 1 To mn
113        TestID = .Cells(LV4Row(m - 1), 2).Value
114myDocument.Shapes.AddShape msoShapeRoundedRectangle, 350, 50 + i * 50, 88, 37
115' シェイプを選択
116Coll4.Add ActiveSheet.Shapes.Item(jn + kn + ln + m)
117'塗りつぶしの設定
118Coll4.Item(m).Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
119Coll4.Item(m).Line.ForeColor.RGB = RGB(0, 0, 0)
120'文字列を入れる
121Coll4.Item(m).DrawingObject.Text = TestID
122Coll4.Item(m).DrawingObject.Font.Color = 0
123i = i + 1
124Next
125     
126End With
127End Sub

上記コードで、以下のように接続関係以外は表示できるかと思います。
接続関係は、図からは読み取れないため実装しておりません。
センスのないコードですみませんが、まずは各レベル毎にデータを整理し、その後順に描画した方が良いかと思います。
配置や、文字、図の色、配置については、好みでご変更いただければと思います。