liulang0808版主做的进度表很漂亮，但增加2022年后线段不对，麻烦大家帮忙修改下，...

fgwei

liulang0808版主做的进度表很漂亮，但增加2022年后划出的线段不对，麻烦大家帮忙修改下，谢谢大家！！！

liulang0808

Sub test()
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next shp
    For j = 6 To ActiveSheet.UsedRange.Rows.Count
        If Len(Cells(j, 5)) * Len(Cells(j, 6)) > 0 Then
        Set rng = Rows(4).Find(Month(Cells(j, 5)) & "月", lookat:=xlWhole)
        Set d1 = Cells(j, Day(Cells(j, 5)) + rng.Column - 1)
        Set rng = Rows(4).Find(Month(Cells(j, 6)) & "月", lookat:=xlWhole)
        Set d2 = Cells(j, Day(Cells(j, 6)) + rng.Column - 1)
        Call get_day(Cells(j, 5), d1)
        d1.Select
        Call get_day(Cells(j, 6), d2)
        y1 = d1.Top + d1.Height / 2
        x1 = d1.Left
        y2 = d1.Top + d1.Height / 2
        x2 = d2.Left + d2.Width
       With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line '.Select
'        Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
            .ForeColor.SchemeColor = 8
            .Weight = 5
        End With
        End If
    Next j
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Target, [e6].Resize(Cells(Rows.Count, 5).End(3).Row, 2)) Is Nothing Then
        Call test
    End If
End Sub
Sub get_day(rng, dt)
    y = Year(rng)
    m = Month(rng)
    d = Day(rng)
    r = rng.Row
    Set rng = Rows(3).Find(Year(rng) & "年", lookat:=xlWhole)
    For j = rng.Column To ActiveSheet.UsedRange.Columns.Count
        If Cells(4, j) = m & "月" Then
            Exit For
        End If
    Next j
   
    Set dt = Cells(r, j + d - 1)
End Sub

liulang0808

增加了一个函数，供参考

朝花夕拾2018

进度计划做得很漂亮，其实用PROJECT软件也不错，成熟的软件。

fgwei

liulang0808版主太牛逼了，一下就解决了，太感谢liulang0808版主了，谢谢，好人有好报！！！

YANWEI82123300

liulang0808老师 太牛,谢谢更新例子