Option Explicit
Dim G_StMFm As String 'マージの開始セル
Dim G_StMTo As String 'マージの終了セル
Dim G_Rg As Range
Dim G_W As Worksheet
Const S_FMRG As String = "D4" '最初に日付を記入するセル（基準セル）
Dim G_Cnt As Long
Dim G_Gyo As Long
Dim G_CMx As Long
Dim G_GyoMx As Long
'↑早く発展編２まで学習を進めて引数つきプロシージャを使いたいところ。グローバル変数多用は可読性メンテナンス性の敵ですので ogawa
'☆演習 - 種々のリライト - 各自で実施してください(本講座参加者でシェアします)

'作成日2018.5.12　10:00

Sub Zentai()
    Worksheets("Keep").Visible = True
    Worksheets("Holidays").Visible = True
    Worksheets("ScheduleGraph_Template").Visible = True
    
    DeleteScheduleGraphSheets
    CreateScheduleGraphTemplate
    SetCatList
    SortByCat
    CreateScheduleGraphSheets
    SortByID
    
    Worksheets("Keep").Visible = False
    Worksheets("Holidays").Visible = False
    Worksheets("ScheduleGraph_Template").Visible = False
    ThisWorkbook.Save 'msgboxで「保存しますか？yes/no」を聞いたほうが親切かも。
End Sub

Sub DeleteScheduleGraphSheets()
    Dim bKeep As Boolean
    Dim wKeep As Worksheet
    Set wKeep = Worksheets("Keep")
    For Each G_W In Worksheets
        bKeep = False
        '.Findメソッドも調べてみましょう ogawa
        For Each G_Rg In wKeep.Range(wKeep.Range("B2"), wKeep.Range("B6"))
            If G_W.Name = G_Rg.Value Then
                bKeep = True
                Exit For
            End If
        Next
        Application.DisplayAlerts = False
        If bKeep = False Then G_W.Delete
        Application.DisplayAlerts = True
    Next
End Sub

Sub CreateScheduleGraphTemplate()
    Dim d As Date
    Dim dFm As Date
    Dim dTo As Date
    Dim bHoliday As Boolean
    Dim holidaycell As Range
    
    Application.DisplayAlerts = False
    For Each G_W In Worksheets
        If G_W.Name = "ScheduleGraph_Template" Then
            G_W.Delete
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Set G_W = ActiveSheet
            G_W.Name = "ScheduleGraph_Template"
            Exit For
        End If
    Next
    Application.DisplayAlerts = True
    
    Set G_Rg = G_W.Range(S_FMRG)
    
    dFm = #1/1/2017#
    dTo = DateAdd("yyyy", 2, dFm)
    
    G_StMFm = G_W.Range("D3").Address
    '↓更新頻繁な部分なので、application.screenupdating の値を設定したほうが高速。ogawa
   '[1]カレンダー右側パーツの作成
    For G_Cnt = 0 To DateDiff("d", dFm, dTo) - 1
        bHoliday = False
        d = DateAdd("d", G_Cnt, dFm)
        '日付の記入
        G_Rg.Offset(0, G_Cnt).Value = d
        '祝日を検索
        Set holidaycell = Worksheets("Holidays").Range("C:C").Find(d)
        If Not holidaycell Is Nothing Then
            bHoliday = True
        End If
        '土日の色を設定
        Select Case True
            Case Format(d, "aaa") = "日" Or bHoliday = True
                G_Rg.Offset(0, G_Cnt).Font.Color = vbRed
            Case Format(d, "aaa") = "土"
                G_Rg.Offset(0, G_Cnt).Font.Color = vbBlue
        End Select
        '年月の記入
        If Day(d) = 1 Then
            G_Rg.Offset(-1, G_Cnt).Value = d
            G_Rg.Offset(-1, G_Cnt).NumberFormatLocal = "yyyy""年""m""月"""
            If G_Cnt > 0 Then
                
                Drawlinerightparts
                
            End If
        End If
    Next
    
    Drawlinerightparts

    With G_W
        G_StMFm = .Range("D3").Address
        .Range(G_StMFm & ":" & G_StMTo).Font.Bold = True
        '日付の表示形式を変更
        G_StMFm = .Range(S_FMRG).Address
        G_StMTo = G_Rg.Offset(0, G_Cnt - 1).Address
        .Range(G_StMFm & ":" & G_StMTo).NumberFormatLocal = "dd"
        '列幅を調整する
        .Cells.ColumnWidth = 2.88
        '行幅を調整する
        .Rows(1).RowHeight = 30
        '行幅を調整する
        .Rows(5).RowHeight = 3
        .Rows("6:7").RowHeight = 17
    End With
    
    '[2]カレンダー左側パーツの作成
    '列幅を調整し、文字を記入(カレンダー左側パーツ)
    With G_Rg.Offset(-1, 0)
        .Offset(, -3).EntireColumn.ColumnWidth = 3.13
        .Offset(, -3).Value = "アクション"
        .Offset(, -3).Font.Size = 14
        .Offset(, -2).EntireColumn.ColumnWidth = 42.13
        .Offset(, -1).EntireColumn.ColumnWidth = 28.13
        .Offset(, -1) = "注意点"
        .Offset(, -1).Font.Size = 14
    End With
     
    DrawlineLeftParts
     
End Sub

Sub Drawlinerightparts()
    '月表示のセルを統合して中央揃え(カレンダー右側パーツ)
    G_StMTo = G_Rg.Offset(-1, G_Cnt - 1).Address
    Application.DisplayAlerts = False
    '以下は ActiveSheet.Range(G_StMFm & ":" & G_StMTo) なら with ひとつで済んだかと。 ogawa
    With ActiveSheet
        With .Range(G_StMFm & ":" & G_StMTo)
            .MergeCells = True
            .HorizontalAlignment = xlCenter
        End With
    End With
    Application.DisplayAlerts = True
    
    '罫線を引く部分(カレンダー右側パーツ)
    G_StMTo = G_Rg.Offset(3, G_Cnt - 1).Address
    With ActiveSheet
        With .Range(G_StMFm & ":" & G_StMTo)
            With .Borders
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeLeft)
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .Weight = xlMedium
            End With
            With .Borders(xlInsideVertical)
                .Weight = xlHairline
            End With
            With .Borders(xlInsideHorizontal)
                .Weight = xlHairline
            End With
        End With
    End With
    G_StMFm = G_Rg.Offset(-1, G_Cnt).Address

End Sub

Sub DrawlineLeftParts()
    'セルを統合して中央揃え(カレンダー左側パーツ)
    With ActiveSheet
        .Range(.Range("A3"), .Range("B4")).MergeCells = True
        .Range(.Range("C3"), .Range("C4")).MergeCells = True
        .Range(.Range("A3"), .Range("C4")).Font.Bold = True
    End With
    
    '罫線を引く部分(カレンダー左側パーツ)
    With ActiveSheet
        With .Range("A5:C6")
            With .Borders
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
            End With
        
            With .Borders(xlEdgeTop)
                .Weight = xlHairline
            End With
            With .Borders(xlEdgeBottom)
                .Weight = xlHairline
            End With
            With .Borders(xlEdgeRight)
                .Weight = xlMedium
            End With
            .Borders(xlInsideVertical).LineStyle = xlNone
            With .Borders(xlInsideHorizontal)
                .Weight = xlHairline
            End With
        End With
        With .Range("A3:B7")
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
        End With
        With .Range("C3:C7")
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .Weight = xlMedium
            End With
        End With
    End With
End Sub

Sub SetCatList()
    '元データ（シート名：List）への､カテゴリidの割り振り (並べ替え用)
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Set wFm = Worksheets("CatList")
    Set wTo = Worksheets("List")
    
    Dim rMxFm As Range
    Dim rMxTo As Range
    Set rMxFm = wFm.Range("B" & wFm.Rows.Count).End(xlUp)
    Set rMxTo = wTo.Range("C" & wFm.Rows.Count).End(xlUp)
    
    Dim rFm As Range
    Dim rCat As Range
    Dim adr As String  ' 最初に見つかったセルのAddress
    
    '(参考)http://www.relief.jp/docs/excel-vba-find-all-rows-number-columns-number.html
    For Each rFm In wFm.Range(wFm.Range("B2"), rMxFm)
        Set rCat = wTo.Range(wTo.Range("C4"), rMxTo).Find(rFm)
        If Not rCat Is Nothing Then
            rCat.Offset(0, -1).Value = rFm.Offset(0, -1).Value
            adr = rCat.Address
        End If
        Do
            Set rCat = wTo.Range(wTo.Range("C4"), rMxTo).FindNext(after:=rCat)
            If rCat.Address = adr Then
              Exit Do
            Else
                rCat.Offset(0, -1).Value = rFm.Offset(0, -1).Value
            End If
        Loop
    Next
    
End Sub

Sub SortByCat()
    '元データ（シート名：List）並べかえ (sortid, アクション,日付)
    Set G_W = Worksheets("List")
    G_CMx = G_W.Range("C" & G_W.Rows.Count).End(xlUp).Row
    Set G_Rg = G_W.Range("A3:I" & G_CMx)
    G_Rg.Sort _
        Key1:=G_W.Range("B4"), Order1:=xlAscending, _
        Key2:=G_W.Range("D4"), Order2:=xlAscending, _
        Key3:=G_W.Range("H4"), Order3:=xlAscending, _
        Header:=xlYes
End Sub

Sub SortBySection()
    '元データ（シート名：List）並べかえ (担当部署)
    Set G_W = Worksheets("List")
    G_CMx = G_W.Range("C" & G_W.Rows.Count).End(xlUp).Row
    Set G_Rg = G_W.Range("A3:I" & G_CMx)
    G_Rg.Sort Key1:=G_W.Range("G4"), Order1:=xlAscending, Header:=xlYes
End Sub

Sub SortByID()
    '元データ（シート名：List）の並びを元に戻す
    Set G_W = Worksheets("List")
    Set G_Rg = G_W.Range("A3:I" & G_CMx)
    G_Rg.Sort Key1:=G_W.Range("A4"), Order1:=xlAscending, Header:=xlYes
End Sub

Sub CreateScheduleGraphSheets()
    '全部門用のシートを準備する
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Set wFm = Worksheets("ScheduleGraph_Template")
    wFm.Copy after:=Worksheets(Worksheets.Count)
    Set wTo = Worksheets(Worksheets.Count)
    wTo.Name = "ScheduleGraph"
    
    Set G_W = Worksheets("List")
    
    G_CMx = G_W.Range("C" & G_W.Rows.Count).End(xlUp).Row
    
    G_Gyo = 4
    G_GyoMx = G_CMx
    
    CreateListToScheduleGraph
    
    SortBySection
    
    '各部署用のシートを準備する
    Set wFm = Worksheets("ScheduleGraph_Template")
    For G_Cnt = 4 To G_CMx
        If G_W.Range("G" & G_Cnt).Value <> G_W.Range("G" & G_Cnt - 1).Value Then
            wFm.Copy after:=Worksheets(Worksheets.Count)
            Set wTo = Worksheets(Worksheets.Count)
            wTo.Name = G_W.Range("G" & G_Cnt).Value

            wTo.Range("C1").Value = G_Cnt
        Else
            wTo.Range("C2").Value = G_Cnt
        End If
    Next

    For G_Cnt = 7 To Worksheets.Count
        With Worksheets(G_Cnt)
            G_Gyo = .Range("C1").Value
            G_GyoMx = .Range("C2").Value
                
            CreateListToScheduleGraph
            
            .Range("C1").ClearContents
            .Range("C2").ClearContents
        End With
    Next
End Sub

Sub CreateListToScheduleGraph()
    Dim cFm As Long
    Dim cTo As Long
    Dim cMxFm As Long
    Dim cMxTo As Long
    Dim wFm As Worksheet
    Set wFm = Worksheets("List")
    
    '変数wToを切り替え
    Dim wTo As Worksheet
    Dim c As Long
    If Worksheets(Worksheets.Count).Name = "ScheduleGraph" Then
        Set wTo = Worksheets(Worksheets.Count)
    Else
        Set wTo = Worksheets(G_Cnt)
    End If
    
    cMxFm = wFm.Range("C" & wFm.Rows.Count).End(xlUp).Row
    cTo = 6

    Dim dFm As Date
    Dim dTo As Date
    Dim cDiff As Long
        
    wTo.Range("A1").Value = wFm.Range("A1").Value
            
    Dim sCom As String
    'レポートシートを作る
    For cFm = G_Gyo To G_GyoMx
        'カテゴリアクションのリストを作り、A列とB列に書き出す
        If wFm.Range("C" & cFm - 1).Value <> wFm.Range("C" & cFm).Value Then
            wTo.Range("A" & cTo).Value = wFm.Range("C" & cFm).Value
            cTo = cTo + 1
            wTo.Rows(cTo).Insert
            wTo.Range("B" & cTo).Value = wFm.Range("D" & cFm).Value
            cTo = cTo + 1
            wTo.Rows(cTo).Insert
        ElseIf wFm.Range("D" & cFm - 1).Value <> wFm.Range("D" & cFm).Value Then
            wTo.Range("B" & cTo).Value = wFm.Range("D" & cFm).Value
            cTo = cTo + 1
            wTo.Rows(cTo).Insert
        End If
        
        '注意点のリストをC列に書き出す
        If wFm.Range("F" & cFm).Value <> "" Then
            If wTo.Range("C" & cTo - 1).Value = "" Then
                wTo.Range("C" & cTo - 1).Value = wFm.Range("F" & cFm).Value
            ElseIf InStr(wTo.Range("C" & cTo - 1).Value, wFm.Range("F" & cFm).Value) = 0 Then
                wTo.Range("C" & cTo - 1).Value = wTo.Range("C" & cTo - 1).Value & ":" & wFm.Range("F" & cFm).Value
            End If
        End If
        'カテゴリがある列に色を塗る
        If wTo.Range("A" & cTo - 2) <> "" Then
            wTo.Range(wTo.Range("A" & cTo - 2), wTo.Range("BRA" & cTo - 2)).Interior.ColorIndex = 35
        End If
        
        dFm = wTo.Range(S_FMRG).Value
        dTo = wFm.Range("H" & cFm).Value
        cDiff = DateDiff("d", dFm, dTo)
        
        'ガントチャート内でイベントのある日に色を塗っている部分
        If wFm.Range("I" & cFm).Value <> "DONE" Then
            'ガントチャート内でイベントを記入
            With wTo.Range("D" & cTo - 1).Offset(, cDiff)
                .Value = "▽" & wFm.Range("E" & cFm).Value & "(" & Mid(dTo, 6) & ")"
                .Font.Bold = False
                .Font.ColorIndex = 1
            End With
        Else
            'ガントチャート内でイベントを記入
            With wTo.Range("D" & cTo - 1).Offset(0, cDiff)
                .Value = "▼" & wFm.Range("E" & cFm).Value & "(" & Mid(dTo, 6) & ")"
                .Font.Bold = False
                .Font.ColorIndex = 1
            End With
        End If
        
        wTo.Range("D" & cTo - 1).Offset(, cDiff).Interior.Pattern = xlGray16
        
        'コメントを入れる部分
        If wFm.Range("F" & cFm).Value <> "" Then
            With wTo.Range("D" & cTo - 1).Offset(, cDiff)
                If .Comment Is Nothing Then
                    .AddComment
                    .Comment.Visible = False
                    .Comment.Text Text:=wFm.Range("F" & cFm).Value
                Else
                    sCom = .Comment.Text
                    .Comment.Text Text:=sCom & vbNewLine & wFm.Range("F" & cFm).Value
                End If
            End With
        End If
    Next
    
    wTo.Rows(cTo).Delete Shift:=xlUp
    cMxTo = wTo.Range("B" & wTo.Rows.Count).End(xlUp).Row
    Dim rHida As Range
    Dim rMigi As Range
    Dim rng As Range
    For cTo = 6 To cMxTo
        If wTo.Range("B" & cTo).Value <> "" Then
            Set rHida = wTo.Range("C" & cTo).End(xlToRight)
            Set rMigi = wTo.Range("XFD" & cTo).End(xlToLeft)
            For Each rng In Range(rHida, rMigi)
                If rng = "" Then
                    rng.Interior.ColorIndex = 19
                Else
                    'セル内の文字列を左寄せ/中央揃え/右寄せ
                    Select Case rng
                        Case rHida
                            rng.HorizontalAlignment = xlLeft
                        Case rMigi
                            rng.HorizontalAlignment = xlLeft
                        Case Else
                            rng.HorizontalAlignment = xlLeft
                    End Select
                End If
            Next
        End If
    Next
    
    '日付の最小値・最大値を調べる
    Set rng = wFm.Range("H4" & ":" & "H" & cMxFm)
    Dim dMin As Date
    Dim dMax As Date
    dMin = WorksheetFunction.Min(rng)
    dMax = WorksheetFunction.Max(rng)
    With wTo
        '必要な列のみ表示
        cDiff = DateDiff("d", dFm, dMin) - 7
        .Range(.Range(S_FMRG), .Range(S_FMRG).Offset(0, cDiff)).EntireColumn.Hidden = True
        
        .Activate
    
        'ウィンド枠の固定
        .Range("D6").Offset(0, cDiff + 1).Select
        ActiveWindow.FreezePanes = True
        cDiff = DateDiff("d", dFm, dMax) + 7
        .Range(.Range(S_FMRG).Offset(0, cDiff), .Range("BRA4")).EntireColumn.Hidden = True
        '列幅調整
        .Range(.Range("B4"), .Range("C4")).EntireColumn.AutoFit
    End With
    
    Worksheets("ScheduleGraph").Activate
End Sub