【VBA】ガントチャート作成

ちょっとシンプルに変更

Sheet2(進捗管理表)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i, j As Long
    i = Target.Row
    j = Target.Column

    c1 = Rows(5).Find("変更前").Column
    c2 = Rows(5).Find("日程").Column
    c3 = Rows(1).Find("開始").Column

    If i > 5 Then
        If j = c1 Or j = c2 Then
            Call schedule_update(i)
       End If
    End If
End Sub

Module1

Option Explicit

Public c1 As Long, c2 As Long, c3 As Long

Sub new_project()

    Dim cmin As Long, cmax As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim d1 As Date, d2 As Date, dx As Date
    Dim newsub As String
    Dim taskno As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim ws As Worksheet
    
    Set ws1 = Worksheets("設定")
    Set ws2 = Worksheets("進捗管理表")
    'Set ws3 = Worksheets("進捗状況")

    'Application.ScreenUpdating = False


    'プロジェクト名称を入れ込む
    newsub = ws1.Range("E2").Value
    
    For Each ws In Worksheets
        If ws.Name = newsub Then
            MsgBox "シートにプロジェクト名と同じ名前があります。"
            Exit Sub
        End If
    Next
    
    '名称を入れ込む
    ws2.Copy After:=ws1
    Set ws4 = ActiveSheet
    
    
    ws4.Range("B1").Value = newsub
    ws4.Name = newsub

    'タスク数を入れ込む
    taskno = ws1.Range("F2").Value
    i = 0
    
    
    '期間を入れ込む
    d1 = ws1.Range("B2").Value
    d2 = ws1.Range("B3").Value
    ws4.Range("B3").Value = d1 & "～" & d2
    
    dx = d1

    With ws4.Range("H3")
        .NumberFormatLocal = "yyyy"
        .Value = dx
    End With

    With ws4.Range("H4")
        .NumberFormatLocal = "mm"
        .Value = dx
    End With

    With ws4.Range("H5")
        .NumberFormatLocal = "d"
        .Value = dx
    End With

    i = 1
    dx = dx + 1

    Do While dx <= d2

        If Left(ws4.Range("H3").Value, 4) <> Left(dx, 4) Then
            ws4.Range("H3").Offset(0, i).NumberFormatLocal = "yyyy"
            ws4.Range("H3").Offset(0, i).Value = dx
        End If

        
        ws4.Range("H4").Offset(0, i).NumberFormatLocal = "mm"
        ws4.Range("H4").Offset(0, i).Value = dx
    
        ws4.Range("H5").Offset(0, i).NumberFormatLocal = "d"
        ws4.Range("H5").Offset(0, i).Value = dx
        
        If Weekday(dx) = 1 Or Weekday(dx) = 7 Then
            ws4.Range("H5:H" & 5 + taskno).Offset(0, i).Interior.ColorIndex = 15
            
        End If
        
        dx = dx + 1
        i = i + 1
    Loop
    
    ws4.Range("A6:G" & taskno + 6).FillDown
    
    For j = 6 To taskno + 5
        ws4.Range("A" & j).Value = j - 5
    Next

    With Range(Cells(5, 1), Cells(5 + taskno, 7 + i))
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With

    Range(Columns(8), Columns(8 + i)).ColumnWidth = 4
    Application.ScreenUpdating = True

End Sub

Sub schedule_update(i)
    Dim d1 As Date, d2 As Date
    Dim j As Long, hiduke As Long
    Dim r1 As Range, r2 As Range
    Dim y As String, m As String, d As String
    Dim tantou As String

    'Application.ScreenUpdating = False
    
    d1 = Cells(i, c1).Value
    d2 = Cells(i, c2).Value
        
    If CStr(d1) = "" Or CStr(d2) = "" Then
        Exit Sub
    End If
    
    j = Cells(5, c3).End(xlToRight).Column

    For j = 0 To j - 7
        'hidukeに格納
        hiduke = Cells(5, c3).Offset(0, j).Value

        '一度、背景を白に戻す
        If Cells(i, c3).Offset(0, j).Interior.ColorIndex <> 15 Then
            Cells(i, c3).Offset(0, j).Interior.ColorIndex = xlNone
        End If
        
        '予定に反映を入れる
        If hiduke = d1 Then
            If Cells(i, c3).Offset(0, j).Interior.ColorIndex <> 15 Then
                Cells(i, c3).Offset(0, j).Interior.Color = vbBlue
            End If
        End If
        
        If hiduke = d2 Then
            If Cells(i, c3).Offset(0, j).Interior.ColorIndex <> 15 Then
                Cells(i, c3).Offset(0, j).Interior.Color = vbGreen
            End If
        End If
        
    Next
    
    Application.ScreenUpdating = True

End Sub

Sub monthly()
    Dim cnt As Long
    cnt = Range("XFD5").End(xlToLeft).Column
    Range(Columns(8), Columns(cnt)).ColumnWidth = 2
End Sub

Sub weekly()
    Dim cnt As Long
    cnt = Range("XFD5").End(xlToLeft).Column
    Range(Columns(8), Columns(cnt)).ColumnWidth = 4
End Sub

参考
https://www.fastclassinfo.com/entry/vba_ganttchart
https://www.relief.jp/docs/excel-vba-find-range.html
https://www.sejuku.net/blog/36936#i-2
https://www.moug.net/tech/exvba/0050057.html
http://www.transsoft.co.jp/blog/?p=1810