ray88’s diary

お仕事で困ったとき用の自分用の覚書

Excel VBA WBS作成

■以下のようなWBSを作成します。
f:id:ray88:20200429160702p:plain
f:id:ray88:20200429160720p:plain
■作成ボタンに登録するマクロ(コード)

Sub WBS作成()
    Dim shp As Shape
    Dim org As Range
    Dim dst As Range
    Dim trgt As Range
    Dim days As Range
    Dim wsPrf As Worksheet
    Dim ctg As Range
    
    Set wsPrf = Worksheets("設定")
    Set days = Range(Range("E2"), Range("E2").End(xlToRight))
    
    For Each trgt In Range(Range("C3"), Range("C3").End(xlDown))
        '開始日に一致するセルを探す
        Set org = days.Find(trgt, , , xlWhole)
        '終了日に一致するセルを探す
        Set dst = days.Find(trgt.Offset(0, 1), , , xlWhole)
        '矢印線の開始位置と終了位置を設定
        Set shp = ActiveSheet.Shapes.AddLine(org.Left + org.Width / 2, _
                  trgt.Top + trgt.RowHeight / 2, dst.Left + dst.Width / 2, _
                  trgt.Top + trgt.RowHeight / 2)
        '設定シートA4~A7の範囲よりSheet1のA列(分類)の項目と合致するセルを検出
        Set ctg = wsPrf.Range("A4:A7").Find(trgt.Offset(0, -2).Value, , , xlWhole)
        With shp.Line
            '設定シートよりセルの幅の値を取得
            .Weight = wsPrf.Range("B1").Value
            '設定シートのB列より色を取得
            .ForeColor.RGB = ctg.Offset(0, 1).Interior.Color
            '線のスタイルを矢印に設定
            .EndArrowheadStyle = msoArrowheadTriangle
        End With
    Next
End Sub

■削除ボタンに登録するマクロ(コード)

Sub 矢印を削除()
    Dim shp As Shape
    'シート内の矢印線のみ削除する
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoLine Then
            shp.Delete
        End If
    Next
End Sub