ガントチャート作成

1日4分割のタイムテーブルでのガントチャート作成
フォーマットとなる日付はマクロで作成
チャート部分は数式をスピルさせる
該当日の種類、進捗により数値が出力されるので
あとは条件付き書式によって好みの色を設定


シート名「休日設定」----------------

　テーブル名「_休日設定」
　列　[日付][休日フラグ]
 　　　※休日の場合は"1"

シート名「スケジュール」------------

　テーブル名「_期間データ」
　列　[開始日][st][完了日][et][期限日][lt][進捗率][完了][取消]
　　　※st,et,lt は"1~4" を入力。完了、取消は"True or 1"
    
　セル「_日付基準セル」
　　　「_月設定」（ex. 2025/1/1, 2025/2/1, ・・・, 2025/12/1；TEXTで月だけ表示にする）


   「_期間データ」の行 + 1
   「_日付基準セル」の列 + 1
   のセルに下記数式
   参考サイト
   https://note.com/excel_dokata/n/n94205a5d3da7

   作業日：1, 進捗率によって：2, 期限：21, 期限(完了済み)：22, 完了：99, 取消：98, その他：0

    =LET(
        dates, OFFSET(_日付基準セル, , 1):OFFSET(_日付基準セル, , 180),
        datestime, OFFSET(_日付基準セル, 1, 1):OFFSET(_日付基準セル, 1, 300),
        startDates, _期間データ[開始日],
        starttime, _期間データ[st],
        endDates, _期間データ[完了日],
        endtime, _期間データ[et],
        limitDates, _期間データ[期限日],
        limittime, _期間データ[lt],
        progressRates, _期間データ[進捗率],
        finish, _期間データ[完了],
        cancel, _期間データ[取消],
        another, _期間データ[rvsc],
        MAKEARRAY(
            ROWS(startDates),
            COLUMNS(dates),
            LAMBDA(rowindex, colindex,
                LET(
                    _date, INDEX(dates, 1, colindex),
                    _time, INDEX(datestime, 1, colindex),
                    _dateforlimit, INDEX(dates, 1, colindex - 1),
                    _timeforlimit, INDEX(datestime, 1, colindex - 1),
                    _startDate, INDEX(startDates, rowindex),
                    _starttime, IF(INDEX(starttime, rowindex) = "", 1, INDEX(starttime, rowindex)),
                    _endDate, INDEX(endDates, rowindex),
                    _endtime, IF(INDEX(endtime, rowindex) = "", 4, INDEX(endtime, rowindex)),
                    _limitDate, INDEX(limitDates, rowindex),
                    _limittime, IF(INDEX(limittime, rowindex) <> "", INDEX(limittime, rowindex), 4),
                    _progressRate, INDEX(progressRates, rowindex),
                    _finish, IF(INDEX(finish, rowindex) = 1, TRUE(), INDEX(finish, rowindex)),
                    _cancel, IF(INDEX(cancel, rowindex) = 1, TRUE(), INDEX(cancel, rowindex)),
                    _another, IF(INDEX(another, rowindex) = 1, TRUE(), INDEX(another, rowindex)),
                    IFS(
                        AND(_limitDate = _dateforlimit, _limittime = _timeforlimit),
                        IF(AND(_finish <> TRUE(), _cancel <> TRUE()), 21, IF(_finish = TRUE(), 22, 23)),
                        OR(_startDate = "", _endDate = "", _date = ""),
                        0,
                        OR(_startDate + (_starttime / 10) > _date + (_time / 10), _endDate + (_endtime / 10) < _date + (_time / 10)),
                        0,
                        _finish = TRUE(),
                        99,
                        _cancel = TRUE(),
                        98,
                        _progressRate = 0,
                        IF(_another = TRUE, 3, 1),
                        ((COUNTIFS(_休日設定[日付], ">=" & _startDate, _休日設定[日付], "<=" & _date, _休日設定[休日フラグ], "<>1") - 2) * 4 + (_time - _starttime + 5)) = 1,
                        IF(_another = TRUE, 4, 2),
                        ((COUNTIFS(_休日設定[日付], ">=" & _startDate, _休日設定[日付], "<=" & _date, _休日設定[休日フラグ], "<>1") - 2) * 4 + (_time - _starttime + 5)) /
                            (
                                (COUNTIFS(_休日設定[日付], ">=" & _startDate, _休日設定[日付], "<=" & _endDate, _休日設定[休日フラグ], "<>1") - 2) * 4 +
                                    (_endtime - _starttime + 5)
                            ) > _progressRate,
                        IF(_another = FALSE(), 1, 3),
                        _another = FALSE(),
                        2,
                        TRUE(),
                        4
                    )
                )
            )
        )
    )

日付生成ツール----------------------------------------------------------------------------------

    Sub Add_Date()
    
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim ws_hlyday As Worksheet
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("スケジュール")
        Set ws_hlyday = wb.Worksheets("休日設定")
    
        Dim tbl As ListObject
       
        Dim end_day As Date
        Dim tmp_month As Long
        Dim tmp_week As Long
        
        Dim rng As Range
        Dim rngSrcDy As Range
        
        Dim i As Long
        
        Set rng = ws.Range("_日付基準セル")
        
        If ws.Range("_月設定") <> "" Then
            end_day = DateSerial(Year(ws.Range("_月設定")), Month(ws.Range("_月設定")), 0)
        Else
            Set rng = ws.Cells(rng.Row, Columns.Count).End(xlToLeft)
            end_day = rng
        End If
        
        With rng.Offset(, 1).Resize(, 300).EntireColumn.Borders(xlInsideVertical)
            .LineStyle = xlLineStyleNone
        End With
        rng.Offset(, 1).Resize(5, 300) = ""
        
        tmp_month = Month(end_day)
        tmp_week = Weekday(end_day)
        
        Set tbl = ws_hlyday.ListObjects("_休日設定")
        
        For Each rngSrcDy In tbl.ListColumns(1).DataBodyRange
            If end_day < rngSrcDy And rngSrcDy < DateSerial(Year(end_day), Month(end_day) + 2, 1) _
                    And rngSrcDy.Offset(, 1) <> 1 Then
                If tmp_week >= Weekday(rngSrcDy) Then
                    With ws.Columns(rng.Column).Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                End If
                If tmp_month < Month(rngSrcDy) Then
                    rng.Offset(2, 2) = "=TEXT(" & rng.Offset(, 1).Address & ",""m月"")"
                    tmp_month = Month(rngSrcDy)
                End If
                rng.Offset(, 1).Resize(1, 4) = rngSrcDy.Value
                For i = 1 To 4
                    rng.Offset(1, i) = i
                Next i
                rng.Offset(3, 2) = "=TEXT(" & rng.Offset(, 1).Address & ",""d"")"
                rng.Offset(4, 2) = "=TEXT(" & rng.Offset(, 1).Address & ",""aaa"")"
                
                    With ws.Columns(rng.Offset(, 4).Column).Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlHairline
                        
                    End With
                tmp_week = Weekday(rngSrcDy)
                
                Set rng = rng.Offset(, 4)
                
              End If
        
        Next rngSrcDy
        
    End Sub



日付（開始日等）入力用のカレンダーツール-----------------------------------------------------------

参考サイト兼フォームコントロール作成方法
https://ateitexe.com/excel-vba-calendar-control2-manual/

シートモジュール
　"スケジュール"シート

    Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

        With ListObjects("_期間データ")
    
            If (Target.Column = .Range(1, 1).Column + .ListColumns("開始日").Index - 1 Or _
                Target.Column = .Range(1, 1).Column + .ListColumns("完了日").Index - 1 Or _
                Target.Column = .Range(1, 1).Column + .ListColumns("期限日").Index - 1) _
                And _
                Target.Row > .Range(1, 1).Row Then
                Call setCalendarDateForCell(Target)
                Cancel = True
            End If
        
        End With

    End Sub


フォームモジュール


    Private Sub UserForm_Initialize()
      '## フォーム読込時
      
      Dim i As Long '汎用変数
      g_isCldCancel = False 'キャンセルフラグをFalseにしておく
      
      For i = -3 To 3 '前後3年分の年をリストに追加
        Me.cmb_year.AddItem Year(g_cldCurrentDate) + i
      Next i
      For i = 1 To 12 '月をリストに追加
        Me.cmb_month.AddItem i
      Next i
        
      Me.cmb_year.Value = Year(g_cldCurrentDate) '年を指定
      Me.cmb_month.Value = Month(g_cldCurrentDate) '月を指定
    End Sub
    
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      '## フォームが閉じる時
      
      If CloseMode = vbFormControlMenu Then '×ボタンで閉じられていたら
        g_isCldCancel = True 'キャンセルフラグをTrue
      End If
    End Sub
    
    Private Sub cmb_year_Change()
      '## 年が変更された時
      Call setCalendar
    End Sub
     
    Private Sub cmb_month_Change()
      '## 月が変更された時
      Call setCalendar
    End Sub
     
    Private Sub setCalendar()
      '## カレンダーの作成と表示
      
      Dim i As Long '汎用変数
       
      If Me.cmb_year.Value = "" Or Me.cmb_month.Value = "" Then Exit Sub '年か月どちらか入ってなければ中止
      
      Dim yy As Long '年取得
      yy = Me.cmb_year.Value
      Dim mm As Long '月取得
      mm = Me.cmb_month.Value
        
      For i = 1 To 37 'ラベルの初期化
        With Me("lbl_day" & i)
          .Caption = "" 'キャプション
          .BorderStyle = fmBorderStyleNone '枠なし
          .BackColor = Me.BackColor 'フォームと同じ背景色へ
        End With
      Next
      
      Dim n As Long '月はじめの位置用変数
      n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、-1したもの
      
      Dim endDay As Long '月末日用変数
      endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '算出
      
      Dim tgtDay As Date '日付生成用変数
      For i = 1 To endDay '1日から月末日まで
        tgtDay = yy & "/" & mm & "/" & i '該当日付生成
        With Me("lbl_day" & n + i) '該当のラベルに対して
          .Caption = i '日を入れる
          If tgtDay = Date Then '今日なら
            .BorderStyle = fmBorderStyleSingle '枠を付ける
          End If
          If tgtDay = g_cldCurrentDate Then '初期値と同日なら
            .BackColor = RGB(200, 200, 200) '背景色を付ける
          End If
        End With
      Next i
    End Sub
    
    Private Sub spn_monthUpDown_SpinUp()
      '## スピンボタンのアップクリック時
      
      On Error GoTo ErrHandler 'エラー時に「ErrHandler」行へジャンプする宣言
      
      If Me.cmb_month.Value = 12 Then '12月だったら
        Me.cmb_year.Value = Me.cmb_year.Value + 1 '年を+1
        Me.cmb_month.Value = 1 '1月へ
      Else
        Me.cmb_month.Value = Me.cmb_month.Value + 1 '月を+1
      End If
      
      Exit Sub
      
    ErrHandler:     'エラー時はここへジャンプする
      MsgBox "ドロップダウンリストに存在しない年数へは移動できません", vbExclamation, "注意"
    End Sub
     
    Private Sub spn_monthUpDown_SpinDown()
      '## スピンボタンのダウンクリック時
      
      On Error GoTo ErrHandler 'エラー時に「ErrHandler」行へジャンプする宣言
      
      If Me.cmb_month.Value = 1 Then '1月だったら
        Me.cmb_year.Value = Me.cmb_year.Value - 1 '年を-1
        Me.cmb_month.Value = 12 '12月へ
      Else
        Me.cmb_month.Value = Me.cmb_month.Value - 1 '月を-1
      End If
      
      Exit Sub
      
    ErrHandler:     'エラー時はここへジャンプする
      MsgBox "ドロップダウンリストに存在しない年数へは移動できません", vbExclamation, "注意"
    End Sub
    
    Private Sub putTgtDate(ByVal i As Long)
      '## グローバル変数に取得した日付をセットする
      
      If Me("lbl_day" & i).Caption = "" Then Exit Sub 'ラベルが空だったら中止
      g_cldPickedDate = Me.cmb_year.Value & "/" & Me.cmb_month.Value & "/" & Me("lbl_day" & i).Caption '日付を生成して変数に格納
      Unload Me 'カレンダーを閉じる
    End Sub
    
    '## 以下、ラベルクリックイベント
    Private Sub lbl_day1_Click() '1番目のラベルだったら
      Call putTgtDate(1) '引数を1で呼び出し
    End Sub
    
    Private Sub lbl_day2_Click()
      Call putTgtDate(2)
    End Sub
    
    Private Sub lbl_day3_Click()
      Call putTgtDate(3)
    End Sub
    
    Private Sub lbl_day4_Click()
      Call putTgtDate(4)
    End Sub
    
    Private Sub lbl_day5_Click()
      Call putTgtDate(5)
    End Sub
    
    Private Sub lbl_day6_Click()
      Call putTgtDate(6)
    End Sub
    
    Private Sub lbl_day7_Click()
      Call putTgtDate(7)
    End Sub
    
    Private Sub lbl_day8_Click()
      Call putTgtDate(8)
    End Sub
    
    Private Sub lbl_day9_Click()
      Call putTgtDate(9)
    End Sub
    
    Private Sub lbl_day10_Click()
      Call putTgtDate(10)
    End Sub
    
    Private Sub lbl_day11_Click()
      Call putTgtDate(11)
    End Sub
    
    Private Sub lbl_day12_Click()
      Call putTgtDate(12)
    End Sub
    
    Private Sub lbl_day13_Click()
      Call putTgtDate(13)
    End Sub
    
    Private Sub lbl_day14_Click()
      Call putTgtDate(14)
    End Sub
    
    Private Sub lbl_day15_Click()
      Call putTgtDate(15)
    End Sub
    
    Private Sub lbl_day16_Click()
      Call putTgtDate(16)
    End Sub
    
    Private Sub lbl_day17_Click()
      Call putTgtDate(17)
    End Sub
    
    Private Sub lbl_day18_Click()
      Call putTgtDate(18)
    End Sub
    
    Private Sub lbl_day19_Click()
      Call putTgtDate(19)
    End Sub
    
    Private Sub lbl_day20_Click()
      Call putTgtDate(20)
    End Sub
    
    Private Sub lbl_day21_Click()
      Call putTgtDate(21)
    End Sub
    
    Private Sub lbl_day22_Click()
      Call putTgtDate(22)
    End Sub
    
    Private Sub lbl_day23_Click()
      Call putTgtDate(23)
    End Sub
    
    Private Sub lbl_day24_Click()
      Call putTgtDate(24)
    End Sub
    
    Private Sub lbl_day25_Click()
      Call putTgtDate(25)
    End Sub
    
    Private Sub lbl_day26_Click()
      Call putTgtDate(26)
    End Sub
    
    Private Sub lbl_day27_Click()
      Call putTgtDate(27)
    End Sub
    
    Private Sub lbl_day28_Click()
      Call putTgtDate(28)
    End Sub
    
    Private Sub lbl_day29_Click()
      Call putTgtDate(29)
    End Sub
    
    Private Sub lbl_day30_Click()
      Call putTgtDate(30)
    End Sub
    
    Private Sub lbl_day31_Click()
      Call putTgtDate(31)
    End Sub
    
    Private Sub lbl_day32_Click()
      Call putTgtDate(32)
    End Sub
    
    Private Sub lbl_day33_Click()
      Call putTgtDate(33)
    End Sub
    
    Private Sub lbl_day34_Click()
      Call putTgtDate(34)
    End Sub
    
    Private Sub lbl_day35_Click()
      Call putTgtDate(35)
    End Sub
    
    Private Sub lbl_day36_Click()
      Call putTgtDate(36)
    End Sub
    
    Private Sub lbl_day37_Click()
      Call putTgtDate(37)
    End Sub


　標準モジュール
 
    'カレンダー用グローバル変数
    Public g_cldCurrentDate As Date 'デフォルトの日付
    Public g_cldPickedDate As Date 'カレンダーで選択された日付
    Public g_isCldCancel As Boolean 'キャンセル判定用
    
    Public Sub setCalendarDateForCell(ByVal tgtRange As Range)
      '## カレンダーで選択した日付をセルに入力する
    
      If IsDate(tgtRange.Cells(1, 1).Value) = False Then '日付が入ってなければ
        g_cldCurrentDate = Date '今日の日付を格納
      Else
        g_cldCurrentDate = tgtRange.Cells(1, 1).Value 'セルの日付を格納
      End If
      
      Dim n
      n = Range("O64").Top
      Load F_Calendar
      F_Calendar.StartUpPosition = 0
      If tgtRange.Top <= 750 Then
        F_Calendar.Top = tgtRange.Top
      Else
        F_Calendar.Top = 400
      End If
      F_Calendar.Left = tgtRange.Left + 130
    
      F_Calendar.Show 'カレンダーを開く
    
      If g_isCldCancel = True Then Exit Sub 'キャンセル（バツボタンで閉じられた）なら終了
      tgtRange.Value = g_cldPickedDate 'クリックされた日付を上書き
    End Sub
　
    ----------------------------------------------------------------------------------

    =LET(
        filterColWord, "月",
        originaldata, INDIRECT(_対象セル),
        srcData, FILTER(
            FILTER(originaldata, CHOOSECOLS(originaldata, XMATCH(filterColWord, CHOOSEROWS(originaldata, 1))) <> 0),
            CHOOSEROWS(originaldata, 1) <> 0
        ),
        orgnFiltColIndex, XMATCH(filterColWord, CHOOSEROWS(srcData, 1)),
        takeOrgn, LAMBDA(x, TAKE(srcData, ROWS(srcData), x)),
        mainary, HSTACK(
            CHOOSECOLS(srcData, orgnFiltColIndex),
            IFS(
                orgnFiltColIndex = COLUMNS(srcData),
                takeOrgn(orgnFiltColIndex - 1),
                orgnFiltColIndex = 1,
                takeOrgn(orgnFiltColIndex - COLUMNS(srcData)),
                TRUE(),
                HSTACK(takeOrgn(orgnFiltColIndex - 1), takeOrgn(orgnFiltColIndex - COLUMNS(srcData)))
            )
        ),
        filterColIndx, XMATCH(filterColWord, CHOOSEROWS(mainary, 1)),
        filterCol, CHOOSECOLS(mainary, filterColIndx),
        headRow, CHOOSEROWS(mainary, 1),
        reduceAry, SORT(UNIQUE(FILTER(filterCol, (filterCol <> filterColWord)))),
        resultAry, REDUCE(
            headRow,
            reduceAry,
            LAMBDA(a,x, VSTACK(a, VSTACK(FILTER(mainary, filterCol = x), BYCOL(FILTER(mainary, filterCol = x), LAMBDA(x, IF(SUM(x) <> 0, SUM(x), ""))))))
        ),
        VSTACK(resultAry, HSTACK("合計", TAKE(BYCOL(resultAry, LAMBDA(x, IF(SUM(x) <> 0, SUM(x) / 2, ""))), 1, 1 - COLUMNS(mainary))))
    )
    
-----------------------------------------------------------------------------------------------

    =LET(
        csfld, FILTER(_CSdata, CHOOSECOLS(_CSdata, 1) <> ""),
        colselct, LAMBDA(x, CHOOSECOLS(csfld, XMATCH(x, CHOOSEROWS(_CSdata, 1), 0))),
        GROUPBY(
            HSTACK(TEXT(colselct("月"), "m月"), colselct("案件")),
            HSTACK(
                colselct("バリ内訳"),
                colselct("件数"),
                colselct("バリ"),
                colselct("情報資産"),
                colselct("機能"),
                colselct("ユニット")
            ),
            HSTACK(LAMBDA(x, TEXTJOIN("", 0, x)), SUM, SUM, SUM, SUM, SUM),
            3,
            -2
        )
    )


----------------------------------------------------------------------------------

    
    Sub test()
    
      Application.ScreenUpdating = False
    
      Dim wb As Workbook
      Dim ws As Worksheet
      Set wb = ThisWorkbook
      Set ws = wb.Worksheets("スケジュール")
    
      Dim i As Long
      Dim k As Long
      Dim j As Long
    
      Dim clm_st As Long
      Dim clm_stT As Long
      Dim clm_fsh As Long
      Dim clm_fshT As Long
      Dim clm_lmt As Long
      Dim clm_lmtT As Long
      Dim clm_prcnt As Long
      Dim clm_fshFlg As Long
      Dim clm_cncl As Long
      Dim clm_anthr As Long
      
      Dim row_tblTop As Long
      Dim row_tblBtm As Long
      Dim clm_L As Long
      Dim clm_R As Long
      
      
      Dim tbl As ListObject
      Set tbl = ws.ListObjects("_期間データ")
      
      Dim str As String
      Dim str2 As String
      
      
      clm_st = tbl.ListColumns("開始日").Range(1).Column
      clm_stT = tbl.ListColumns("st").Range(1).Column
      
      clm_fsh = tbl.ListColumns("完了日").Range(1).Column
      clm_fshT = tbl.ListColumns("et").Range(1).Column
      clm_lmt = tbl.ListColumns("期限日").Range(1).Column
      clm_lmtT = tbl.ListColumns("lt").Range(1).Column
      clm_prcnt = tbl.ListColumns("進捗率").Range(1).Column
      clm_fshFlg = tbl.ListColumns("完了").Range(1).Column
      clm_cncl = tbl.ListColumns("取消").Range(1).Column
      clm_anthr = tbl.ListColumns("rvsc").Range(1).Column
      
      row_tblTop = tbl.ListRows(1).Range.Row
      row_tblBtm = row_tblTop + tbl.ListRows.Count - 1
      clm_L = ws.Range("_日付基準セル").Column + 1
      clm_R = ws.Range("_日付基準セル").End(xlToRight).Column
      
    '  str2 = tbl.HeaderRowRange
    
      Dim dyst As Date
      Dim dyfs As Date
      Dim dylm As Date
      Dim tmst As Long
      Dim tmfs As Long
      Dim tmlm As Long
      
      Dim dycel As Date
      Dim tmcel As Long
      
      Dim progressRate As Double
      
      Dim flg_fs As Boolean
      Dim flg_cl As Boolean
      Dim flg_anthr As Boolean
      
      Dim num As Long
      
      Dim rng_st As Range
      Dim rng_ed As Range
      Dim rng_cel As Range
      
      Dim hgt As Long
      Dim whd As Long
      
      Dim denominator As Long
      Dim numerator As Long
      
      Dim ary() As Variant
      
      hgt = row_tblBtm - row_tblTop + 1
      whd = clm_R - clm_L + 1
      
      ws.Cells(row_tblTop, clm_L).Resize(hgt, whd).ClearContents
      
      ReDim ary(1 To hgt, 1 To whd)
      
      For i = row_tblTop To row_tblBtm
      
        dyst = ws.Cells(i, clm_st)
        dyfs = ws.Cells(i, clm_fsh)
        dylm = ws.Cells(i, clm_lmt)
        tmlm = ws.Cells(i, clm_lmtT)
        If tmlm = 0 Then
          tmlm = 4
        End If
        
        If (dyst = "0:00:00" Or dyfs = "0:00:00") Then
           If dylm <> "0:00:00" Then
            For k = clm_L To clm_R
              If ws.Cells(1, k - 1) = dylm And ws.Cells(2, k - 1) = tmlm Then
                If flg_fs = True Or flg_cl = True Then
                  ary(i, k) = 22
                Else
                  ary(i, k) = 21
                End If
                Exit For
              End If
            Next k
           End If
        
          GoTo nextloop
        End If
        
        tmst = ws.Cells(i, clm_stT)
        If tmst = 0 Then
          tmst = 1
        End If
        tmfs = ws.Cells(i, clm_fshT)
        If tmfs = 0 Then
          tmfs = 4
        End If
        
        flg_fs = ws.Cells(i, clm_fshFlg)
        flg_cl = ws.Cells(i, clm_cncl)
        flg_anthr = ws.Cells(i, clm_anthr)
    
      
      
        For k = clm_L To clm_R
        
          dycel = ws.Cells(1, k)
          tmcel = ws.Cells(2, k)
          num = 0
        

          
            If (dyst = dycel And tmst <= tmcel) Or _
               (dyst < dycel And dyfs > dycel) Or _
               (dyfs = dycel And tmfs >= tmcel) Then
            
              If flg_fs = True Then
                num = 99
              ElseIf flg_cl = True Then
                num = 98
              Else
                progressRate = ws.Cells(i, clm_prcnt)
                For j = clm_L To clm_R
                  If ws.Cells(1, j) = dyst And ws.Cells(2, j) = tmst Then
                    Set rng_st = ws.Cells(1, j)
                  End If
                  If ws.Cells(1, j) = dyfs And ws.Cells(2, j) = tmfs Then
                    Set rng_ed = ws.Cells(1, j)
                  End If
                  If ws.Cells(1, j) = dycel And ws.Cells(2, j) = tmcel Then
                    Set rng_cel = ws.Cells(1, j)
                  End If
                Next j
                denominator = rng_ed.Column - rng_st.Column + 1
                numerator = rng_cel.Column - rng_st.Column + 1
                If numerator / denominator <= progressRate Then
                  num = 2
                Else
                  num = 1
                End If
              
              End If
      '        Debug.Print ws.Cells(i, k).Address
            End If
 
          
          If dylm = ws.Cells(1, k - 1) And tmlm = ws.Cells(2, k - 1) Then
            num = 21
          End If
        
    
          ary(i - row_tblTop + 1, k - clm_L + 1) = num
    '      ws.Cells(i, k) = num
        
        Next k
        
    nextloop:
        
      Next i
        
      ws.Cells(row_tblTop, clm_L).Resize(hgt, whd) = ary
    
    End Sub


-------------------------------------------------------------------------------------


    Sub DeleteRow()
    
      Dim wb As Workbook
      Dim ws As Worksheet
      Set wb = ThisWorkbook
      Set ws = wb.Worksheets("スケジュール")
      
      Dim tbl As ListObject
      Set tbl = ws.ListObjects("_期間データ")
      
    '  汎用変数
      Dim i As Long, k As Long
      Dim rng As Range
      Dim lpRng As Range
      Dim flg As Boolean
      
    '  用途付帯変動変数
      Dim kpRow As Long
      Dim srchRng As Range
      Dim ary() As Variant
      Dim flgS As Boolean
      
    '  セル位置規定変数
      Dim tblBtm As Long
      Dim schClm As Long
      
      Const wrk As String = "案件"
      Const athr As String = "その他"
      
      
      schClm = ws.Range("_分類1").Column
      tblBtm = tbl.ListRows.Count + tbl.Range(1, 1).Row - 1
      Set srchRng = ws.Range(ws.Cells(1, schClm), ws.Cells(tblBtm, schClm))
      
      k = 0
      For Each rng In srchRng
        Select Case rng
          Case wrk, athr
            ReDim Preserve ary(1, k)
            ary(0, k) = rng.Value
            Do Until rng.Column = 1
              Set rng = rng.Offset(-1, -1)
              If rng = "" Then
                Set rng = rng.Offset(1, 1)
                Exit Do
              End If
            Loop
            ary(1, k) = rng.Row
            k = k + 1
          Case athr
        End Select
      Next rng
      
      Set rng = Nothing
      flgS = False
      flg = False
      For i = 0 To UBound(ary, 2)
        If flg = False Then
          If ary(0, i) = athr Then
            kpRow = ary(1, i)
            flg = True
          End If
        Else
          Select Case True
            Case ary(0, i) <> wrk
            Case flgS = False
              Set rng = ws.Range(ws.Cells(kpRow, 1), ws.Cells(ary(1, i) - 1, 1))
              flgS = True
            Case Else
              Set rng = Union(rng, ws.Range(ws.Cells(kpRow, 1), ws.Cells(ary(1, i) - 1, 1)))
          End Select
          flg = False
        End If
      Next i
      
      If flg = True Then
        Set rng = Union(rng, ws.Range(ws.Cells(kpRow, 1), ws.Cells(tblBtm, 1)))
      End If
        
      
      
    '  rng.EntireRow.Select
    
      If Not rng Is Nothing Then
        flg = False
        For Each lpRng In rng
          If Not lpRng.EntireRow.Hidden Then
            rng.EntireRow.Hidden = True
            flg = True
            Exit For
          End If
        Next lpRng
      
        If flg = False Then
          rng.EntireRow.Hidden = False
        End If
      End If
    
    
    End Sub