T.S.さん:

添削を返送します。
今でも十分に実務利用可能と思います。
部署ごとシートの作成アイデア、すばらしいです。そして、色合いもキレイでよいですね (^^*

基本的な力がとてもしっかりあるということがよく伝わってくるマクロです。
さらにブラッシュアップできるとよいですね。

Option Explicit
Dim G_Gyo As Long
Dim G_GyoMx As Long
Dim G_Cnt As Long

'[12] 演習問題1: 各自で自由にアレンジしてガントチャートを作成する (本講座参加者でシェアします)
'[13] 演習問題2: 各部署向けのガントチャートを生成するマクロを作る (同一ファイル内)

'作成日2018.4.30　15:00

Sub Zentai()
    DeleteScheduleGraphSheets
    SetCatList
    SortByCat
    CreateScheduleGraphSheets
    SortByID
End Sub

Sub DeleteScheduleGraphSheets()
    Dim c As Long
    Application.DisplayAlerts = False
    '削除するシートの指定方法はいろいろ考えられますね ogawa
    For c = Worksheets.Count To 6 Step -1
        Worksheets(c).Delete
    Next
    Application.DisplayAlerts = True
End Sub

Sub SetCatList()
    '元データ（シート名：List）への､カテゴリidの割り振り (並べ替え用)
    
    '発展編１レベルであれば .Find メソッド。発展編２レベルであれば連想配列を使って解決するとより高速です ogawa
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Set wFm = Worksheets("CatList")
    Set wTo = Worksheets("List")
    
    Dim cFm As Long
    Dim cTo As Long
    Dim cMxFm As Long
    Dim cMxTo As Long
    
    cMxFm = wFm.Range("A" & wFm.Rows.Count).End(xlUp).Row
    cMxTo = wTo.Range("C" & wFm.Rows.Count).End(xlUp).Row
    
    For cTo = 4 To cMxTo
        For cFm = 2 To cMxFm
            If wTo.Range("C" & cTo).Value = wFm.Range("B" & cFm).Value Then
                wTo.Range("B" & cTo).Value = wFm.Range("A" & cFm).Value
                Exit For
            End If
        Next
    Next
End Sub

Sub SortByCat()
    '元データ（シート名：List）並べかえ (sortid, アクション,日付)
    Dim w As Worksheet
    Set w = Worksheets("List")

    Dim cMx As Long
    cMx = w.Range("C" & w.Rows.Count).End(xlUp).Row
    
    Dim rg As Range
    Set rg = w.Range("A3:I" & cMx)

    rg.Sort Key1:=w.Range("B4"), _
        Order1:=xlAscending, _
        Key2:=w.Range("D4"), _
        Order2:=xlAscending, _
        Key3:=w.Range("H4"), _
        Order3:=xlAscending, _
        Header:=xlYes
End Sub

Sub SortBySection()
    '元データ（シート名：List）並べかえ (担当部署)
    Dim w As Worksheet
    Set w = Worksheets("List")

    Dim cMx As Long
    cMx = w.Range("C" & w.Rows.Count).End(xlUp).Row
    
    Dim rg As Range
    Set rg = w.Range("A3:I" & cMx)

    rg.Sort Key1:=w.Range("G4"), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub

Sub SortByID()
    '元データ（シート名：List）の並びを元に戻す
    Dim w As Worksheet
    Set w = Worksheets("List")

    Dim cMx As Long
    cMx = w.Range("C" & w.Rows.Count).End(xlUp).Row
    
    Dim rg As Range
    Set rg = w.Range("A3:I" & cMx)

    rg.Sort Key1:=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"
    
    Dim c As Long
    Dim w As Worksheet
    Set w = Worksheets("List")
    
    Dim cMx As Long
    cMx = w.Range("C" & w.Rows.Count).End(xlUp).Row
    
    G_Gyo = 4 '定数を使うというのもありそう ogawa
    G_GyoMx = cMx
    
    '↓以下２つ、分割上手いですね。
    CreateListToScheduleGraph
    
    SortBySection
    
    '各部署用のシートを準備する
    Set wFm = Worksheets("ScheduleGraph_Template")
    For c = 4 To cMx
        If w.Range("G" & c).Value <> w.Range("G" & c - 1).Value Then
            wFm.Copy after:=Worksheets(Worksheets.Count)
            Set wTo = Worksheets(Worksheets.Count)
            wTo.Name = w.Range("G" & c).Value

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

    For G_Cnt = 7 To Worksheets.Count
        G_Gyo = Worksheets(G_Cnt).Range("C1").Value
        G_GyoMx = Worksheets(G_Cnt).Range("C2").Value
            '↓インデントひとつよけい ogawa
            CreateListToScheduleGraph
        '以下２行は、左辺の変数不要。 ogawa
        G_Gyo = Worksheets(G_Cnt).Range("C1").ClearContents
        G_GyoMx = Worksheets(G_Cnt).Range("C2").ClearContents
    Next
End Sub

'発展編２レベルになると、引数つきプロシージャを使い、さらにひきしまったプログラムを書けるようになります。
'  モジュールレベル変数不要に
'   Worksheets(G_Cnt).Range("C1"),  Worksheets(G_Cnt).Range("C2") への値投入不要に ogawa
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
    
    '以下、適切なタイミングでのコメントがとても秀逸です。 ogawa
    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 Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            wTo.Range("B" & cTo).Value = wFm.Range("D" & cFm).Value
            cTo = cTo + 1
            wTo.Rows(cTo).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        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 Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        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("D4").Value
        dTo = wFm.Range("H" & cFm).Value
        cDiff = DateDiff("d", dFm, dTo)
        
        'ガントチャート内でイベントのある日に色を塗っている部分
        If wFm.Range("I" & cFm).Value <> "DONE" Then
            'ガントチャート内でイベントを記入
            wTo.Range("D" & cTo - 1).Offset(, cDiff).Value = "▽" & wFm.Range("E" & cFm).Value & "(" & Mid(dTo, 6) & ")"
            wTo.Range("D" & cTo - 1).Offset(, cDiff).Font.Bold = False '★
            wTo.Range("D" & cTo - 1).Offset(, cDiff).Font.ColorIndex = 1 '★
        Else
            'ガントチャート内でイベントを記入
            wTo.Range("D" & cTo - 1).Offset(0, cDiff).Value = "▼" & wFm.Range("E" & cFm).Value & "(" & Mid(dTo, 6) & ")" '★
            wTo.Range("D" & cTo - 1).Offset(0, cDiff).Font.Bold = False '★
            wTo.Range("D" & cTo - 1).Offset(0, cDiff).Font.ColorIndex = 1 '★
        End If
        
        wTo.Range("D" & cTo - 1).Offset(, cDiff).Interior.Pattern = xlGray16  '★
        
        'コメントを入れる部分
        If wFm.Range("F" & cFm).Value <> "" Then
            If wTo.Range("D" & cTo - 1).Offset(, cDiff).Comment Is Nothing Then
                wTo.Range("D" & cTo - 1).Offset(, cDiff).AddComment
                wTo.Range("D" & cTo - 1).Offset(, cDiff).Comment.Visible = False
                wTo.Range("D" & cTo - 1).Offset(, cDiff).Comment.Text Text:=wFm.Range("F" & cFm).Value
            Else
                sCom = wTo.Range("D" & cTo - 1).Offset(, cDiff).Comment.Text
                wTo.Range("D" & cTo - 1).Offset(, cDiff).Comment.Text Text:=sCom & vbNewLine & wFm.Range("F" & cFm).Value
            End If
        End If
    Next
    
    wTo.Rows(cTo).Delete Shift:=xlUp
    cMxTo = wTo.Range("B1048576").End(xlUp).Row
    Dim cHida As Long
    Dim cMigi As Long
    Dim cYoko As Long
    For cTo = 6 To cMxTo
        If wTo.Range("B" & cTo).Value <> "" Then
            '↓発展編１レベルでは For Each構文を使いたいところ。 ogawa
            cHida = wTo.Range("C" & cTo).End(xlToRight).Column - 3
            cMigi = wTo.Range("XFD" & cTo).End(xlToLeft).Column - 3
            For cYoko = cHida To cMigi
                If wTo.Range("C" & cTo).Offset(0, cYoko).Value = "" Then
                    wTo.Range("C" & cTo).Offset(0, cYoko).Interior.ColorIndex = 19
                Else
                    'セル内の文字列を左寄せ/中央揃え/右寄せ
                    If cYoko = cHida Then
                        wTo.Range("C" & cTo).Offset(, cYoko).HorizontalAlignment = xlLeft
                    ElseIf cYoko = cMigi Then
                        wTo.Range("C" & cTo).Offset(, cYoko).HorizontalAlignment = xlLeft
                    Else
                        wTo.Range("C" & cTo).Offset(, cYoko).HorizontalAlignment = xlLeft
                    End If
                End If
            Next
        End If
    Next
    
    '日付の最小値・最大値を調べる
    '↓うまいです ogawa
    Dim rng As Range
    Set rng = wFm.Range("H4" & ":" & "H" & cMxFm)
    
    Dim dMin As Date
    Dim dMax As Date
    dMin = WorksheetFunction.Min(rng)
    dMax = WorksheetFunction.Max(rng)
    
    '必要な列のみ表示
    cDiff = DateDiff("d", dFm, dMin) - 7
    wTo.Range(wTo.Range("D4"), wTo.Range("D4").Offset(0, cDiff)).EntireColumn.Hidden = True
    
    wTo.Activate

    'ウィンド枠の固定
    wTo.Range("D6").Offset(0, cDiff + 1).Select
    ActiveWindow.FreezePanes = True
    cDiff = DateDiff("d", dFm, dMax) + 7
    wTo.Range(wTo.Range("D4").Offset(0, cDiff), wTo.Range("BRA4")).EntireColumn.Hidden = True
    '列幅調整
    wTo.Range(wTo.Range("B4"), wTo.Range("C4")).EntireColumn.AutoFit
    
    Worksheets("ScheduleGraph").Activate
End Sub

> [12] 演習問題1: 各自で自由にアレンジしてガントチャートを作成する
> [13] 演習問題2: 各部署向けのガントチャートを生成するマクロを作る(同一ファイル内)
> の作成が完了しました。よろしくお願いいたします。
>
> 私の会社では、ガンチャートのイベントを▼、▽で表現する方が多いので
> 会社で使えるように作成しました。
>
> 各部署向けのガントチャートを生成する際にデータを削除する方法でなく
> 一つ一つデータを転記するところが難しかったです。

2018/05/01 02:00

小川先生

添削下さり、ありがとうございます。
本教材でわからない（あやふや）な点を基礎編、発展編等の関連講座
を見て復習しています。
次は、「ガントチャート作成講座アドバンスド講座 」の演習に
進みたいと思います。

> T.S.さん:
>
> 添削を返送します。

2018/05/04 21:26

T.S.さん:

お楽しみください。
ここまでのものを自力で作られたのであれば、まず安心です。


> 小川先生
>
> 添削下さり、ありがとうございます。
> 本教材でわからない（あやふや）な点を基礎編、発展編等の関連講座
> を見て復習しています。
> 次は、「ガントチャート作成講座アドバンスド講座 」の演習に
> 進みたいと思います。
>
> > T.S.さん:
> >
> > 添削を返送します。
>

2018/05/05 18:09