スケジュール管理表を作成 ⑥ セルのダブルクリックで終了時刻を15分単位で入力

先日から、スケジュール管理表をExcelで作成している。
infoment.hatenablog.com
今日も、前回の続きから。
f:id:Infoment:20210117113134p:plain

その案件が終わって、終了時刻を入力するとき。手入力するならば都度、
時計に目を向けねばならない。また、タイプミスが起きる恐れもある。
そこで、ダブルクリックで終了時刻を入力することにした。
f:id:Infoment:20210117113431p:plain

例えば、11:07分にその案件を終えたとき。人毎に様々な考え方があって、
私は１分単位で管理する必要は無いと思っている。大まかに仕事の予定と
実績（予実）を管理するならば、15分単位ぐらいで良い。従って

11:07 ⇒ 11:00
11:08 ⇒ 11:15

のように七捨八入することにした。Excelでは、MRound関数を用いる。
support.microsoft.com

これを、シートのダブルクリックイベントに設定してみよう。
↓ シートモジュール。

Private Property Get Tb() As ListObject
     Set Tb = Me.ListObjects(1)
End Property

Private Function wf() As WorksheetFunction
    Set wf = WorksheetFunction
End Function

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

        If Intersect(Target, Tb.ListColumns("終了時刻").DataBodyRange) Is Nothing Then
            Exit Sub
        ElseIf Target.Offset(-1) = vbNullString Then
            MsgBox "一つ前の項目が未だ終わっていません。"
            Cancel = True
            Exit Sub
        End If
        
        Target = wf.MRound(Time, "00:15")
        Cancel = True
End Sub

では、実際にやってみよう。
f:id:Infoment:20210117114439g:plain
想定通り、15分単位で入力することができた。

ところで、以下の三つは今までユーザー定義関数で算出していた。

終了予定時刻
残り時間
実際作業時間

引数もなく、単にセルに「=tm終了予定時刻()」のように入力してあって、
考えてみると値がセットしてあるのと何ら変わりがない。むしろ、再計算
のタイミングに気を遣う必要があるなどで、デメリットの方が多いような
気がしてきた。

そこで思い切って、UpdateTableに全て盛り込むことにした。
↓ 標準モジュール。

Private Function wf() As WorksheetFunction
    Set wf = WorksheetFunction
End Function

Public Sub UpdateTable()

    ' 無限ループ回避のため、シートのチェンジイベントを一時停止。
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    On Error GoTo er:

    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    ' 罫線クリア。
        Tb.DataBodyRange.Borders.LineStyle = xlNone

    Dim arr As Variant
        arr = Tb.DataBodyRange
        
    Dim i As Long
        For i = 1 To UBound(arr)
            ' 終了予定時刻。
            If arr(i, en実施内容) = vbNullString Then
                arr(i, en終了予定時刻) = vbNullString
            ElseIf i = 1 Then
                arr(i, en終了予定時刻) = CDate(arr(i, en作業予定時間)) + tm始業時刻
            ElseIf arr(i - 1, en終了時刻) = vbNullString Then
                arr(i, en終了予定時刻) = CDate(arr(i, en作業予定時間)) + CDate(arr(i - 1, en終了予定時刻))
            Else
                arr(i, en終了予定時刻) = CDate(arr(i, en作業予定時間)) + CDate(arr(i - 1, en終了時刻))
            End If
            
            ' 残り時間。
            If arr(i, en終了予定時刻) = vbNullString Or _
               arr(i, 列名.en終了時刻) <> vbNullString Then
                arr(i, en残り時間) = vbNullString
            ElseIf CDate(arr(i, en終了予定時刻)) >= Time Then
                arr(i, en残り時間) = Format(CDate(arr(i, en終了予定時刻)) - Time, "hh:mm")
            Else
                arr(i, en残り時間) = Format(Time - CDate(arr(i, en終了予定時刻)), "-hh:mm")
            End If
            
            ' 実際作業時間。
            If arr(i, en終了時刻) = vbNullString Then
                arr(i, en実際作業時間) = vbNullString
            ElseIf i = 1 Then
                arr(i, en実際作業時間) = CDate(arr(i, en終了時刻)) - tm始業時刻
            Else
                arr(i, en実際作業時間) = CDate(arr(i, en終了時刻)) - CDate(arr(i - 1, en終了時刻))
            End If
        Next i
    

    ' 更新後の値セット。
        Tb.DataBodyRange = arr

    ' 数式の再セット。
        Tb.ListColumns(enNo).DataBodyRange = "=ROW()-ROW(" & Tb.Range(1).Address & ")"
        Tb.ListColumns(en●).DataBodyRange = "=IF([@作業予定時間]="""","""",""●"")"
        Tb.ListColumns(en予実比率).DataBodyRange = "=IF([@実際作業時間]="""","""",[@実際作業時間]/[@作業予定時間])"
    
    Dim ListRow As Excel.ListRow
        For Each ListRow In Tb.ListRows
            With ListRow
            ' ●のサイズ修正。
                .Range(en●).Font.Size = wf.MRound(6 * (Hour(.Range(en作業予定時間)) + _
                                                        Minute(.Range(en作業予定時間)) / 60) + 1, 2)
            ' 残り時間の文字色設定。
                Select Case Left(.Range(en残り時間), 1)
                    Case "-"
                        .Range(en残り時間).Font.Color = 192
                    Case Else
                        .Range(en残り時間).Font.Color = vbBlack
                End Select
            End With
        Next
        
    ' 罫線の再描画。
        For Each ListRow In Tb.ListRows
            If ListRow.Range(en終了予定時刻) >= tm終業予定 Then
                ListRow.Range.Borders.Item(xlEdgeBottom).Weight = xlThin
                Exit For
            End If
        Next
    
er:
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Public Property Get tm始業時刻() As Date
    If ActiveSheet.Range("始業時刻") = vbNullString Then
        tm始業時刻 = TimeValue("8:00")
    Else
        tm始業時刻 = Range("始業時刻")
    End If
End Property

Public Property Get tm終業予定() As Date
    If ActiveSheet.Range("終業予定") = vbNullString Then
        tm終業予定 = TimeValue("17:00")
    Else
        tm終業予定 = Range("終業予定")
    End If
End Property

実は先程のＧＩＦアニメは、上記置き換え後のものだ。今のところ、

作業予定時間
終了時刻

のどちらかが変わった時点で更新することとしている。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ListRow As Excel.ListRow
        Select Case Target.Column - Tb.Range(1).Column + 1
            Case 列名.en作業予定時間, 列名.en終了時刻
                Call UpdateTable

        End Select
End Sub

今回は、ここまで。
次回は、案件追加用のフォーム作成に挑戦です。

参考まで。