稲妻線を引くマクロ(VBA)

シート名やカラムは各自で調整

Sub DrawZigZagLine()
    Dim wsSchedule As Worksheet
    Dim wsMacro As Worksheet
    Dim baseDate As Date
    Dim monthCell As Range
    Dim startX As Double, startY As Double
    Dim shapeList() As Variant
    Dim shapeName As String
    Dim progressRate As Double
    Dim shapeTop As Double
    Dim tempList() As Variant
    Dim points() As Variant
    Dim shapeInfoList As Variant
    Dim i As Long, j As Long
    Dim count As Long
    Dim lineShape As Shape
    Dim isBeforeWork As Boolean
    
    Set wsSchedule = Worksheets(RENDING_SHEET)
    Set wsMacro = Worksheets(MACRO_SETTING)

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' 既存稲妻線削除（対象線だけ消す）
    For Each lineShape In wsSchedule.Shapes
        If InStr(lineShape.Name, ZIGZAG_LINE) > 0 Then
            lineShape.Delete
        End If
    Next

    ' 基準日確認
    baseDate = wsMacro.Range(BASE_DATE).Value

    ' 基準日の列取得
    For Each monthCell In wsSchedule.Range(SCHEDULE_RANGE).Cells
        If IsDate(monthCell.Value) Then
            If Format(monthCell.Value, DAY_FORMAT) = Format(baseDate, DAY_FORMAT) Then
                Exit For
            End If
        End If
    Next

    If monthCell Is Nothing Then
        MsgBox "基準日が正しくありません", vbExclamation
        Exit Sub
    End If

    ' 起点座標計算（横幅からX座標を算出）
    startX = monthCell.Left + (Day(baseDate) / 30) * monthCell.Width
    startY = monthCell.Top

    ' 工程名・進捗率取得
    For i = 1 To wsMacro.Cells(Rows.Count, PROCESS_NAME_COLUMN).End(xlUp).Row
        If wsMacro.Cells(i, PROCESS_NAME_COLUMN).Value <> "" Then
            shapeName = wsMacro.Cells(i, PROCESS_NAME_COLUMN).Value
            progressRate = wsMacro.Cells(i, RATE_OF_PROCESS_COLUMN).Value
        Else
            MsgBox "対象の工程名または進捗率がありません：" & wsMacro.Cells(i, RATE_OF_PROCESS_COLUMN).Address, vbExclamation
            Exit Sub
        End If

        Set shape = Nothing
        For Each lineShape In wsSchedule.Shapes
            If lineShape.Name = shapeName Then
                Set shape = lineShape
                Exit For
            End If
        Next

        If Not shape Is Nothing Then
            ReDim Preserve shapeList(count)
            shapeList(count) = Array(shapeName, progressRate, shape.Top)
            count = count + 1
        End If
    Next

    If count = 0 Then
        MsgBox "表示する対象工程がありません", vbExclamation
        Exit Sub
    End If

    ' Y座標でソート
    Dim temp() As Long
    Dim tempPos As Variant
    For i = 0 To count - 2
        For j = i + 1 To count - 1
            If shapeList(i)(2) > shapeList(j)(2) Then
                tempPos = shapeList(i)
                shapeList(i) = shapeList(j)
                shapeList(j) = tempPos
            End If
        Next
    Next

    ' 稲妻線ポイント算出
    points = ConstructZigZagLinePoints(wsSchedule, shapeList, count, startX, startY)

    ' 線を引く
    DrawPolyline wsSchedule, points

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Private Function ConstructZigZagLinePoints(wsSchedule As Worksheet, shapeList() As Variant, count As Long, startX As Double, startY As Double) As Variant
    Dim positions() As Variant
    Dim i As Long
    Dim currentY As Double
    Dim nextY As Double
    Dim nextX As Double
    Dim shape As Shape
    Dim progressRate As Double

    ReDim positions(count + 1)

    ' 起点
    positions(0) = Array(startX, startY)

    For i = 0 To count - 1
        Set shape = wsSchedule.Shapes(shapeList(i)(0))
        currentY = shape.Top

        ' 進捗位置算出（%から小数に変換）
        progressRate = shapeList(i)(1) / 100
        nextX = shape.Left + shape.Width * progressRate
        nextY = shape.Top + shape.Height / 2

        positions(i + 1) = Array(nextX, nextY)
    Next

    ConstructZigZagLinePoints = positions
End Function

Private Sub DrawPolyline(wsSchedule As Worksheet, points As Variant)
    Dim i As Long
    Dim shp As Shape
    Dim lineObj As Variant

    Set lineObj = wsSchedule.Shapes.AddPolyline(points)

    With lineObj.Line
        .ForeColor.RGB = RGB(255, 0, 0)
        .Weight = 2
    End With
End Sub