スケジュール管理表を作成 ⑩ まとめ

Excel VBA

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

前回までで、一応の完成を見せたスケジュール表。
数日間にわたり、業務で使用してみた。結果、幾つかの細かな修正を経た
ものの、全体的に問題なく使用することが出来た。

ということで、今日は全体的なまとめを行う。

シートについて

基本的なシートは、以下の二つ。

  1. 定例業務　朝一番に行う業務を記すシート
  2. 原紙　日々のスケジュールを作成するシート

定例業務には、「定例業務テーブル」を作成。
f:id:Infoment:20210129221626p:plain

記入例は、こんな感じで。
f:id:Infoment:20210129221729p:plain

なお、定例業務シートのオブジェクト名はプロジェクトエクスプローラーで
一番上に来るように、Sheet0とした。
f:id:Infoment:20210129221846p:plain

原紙シートのレイアウトは、こんな感じ。
f:id:Infoment:20210129221946p:plain

入力するのは、黄色の４列のみ。
f:id:Infoment:20210129223000p:plain

Ｂ１セルの日時は、Now関数とユーザー定義書式で表現している。
f:id:Infoment:20210129222041p:plain
f:id:Infoment:20210129222116p:plain

以下の４つは、任意に設定可能。なお、４つの時間および時刻を入力するセルは
それぞれ、各ラベルと同じ文字列で名前が付いている。
例）「08:00」と入力されたセルの名前は「始業時刻」
f:id:Infoment:20210129222309p:plain

関数がセットされているのは、次の３列

  1. Ａ列：=ROW()-ROW($A$2)
  2. Ｄ列：=IF([@作業予定時間]="","","●")
  3. Ｉ列：=IF([@実際作業時間]="","",[@実際作業時間]/[@作業予定時間])

ActiveXコントロールで、ボタンを４つ配置。
f:id:Infoment:20210129222701p:plain
各オブジェクト名は、以下のとおり。

  1. cb作成
  2. cb更新
  3. cb中断
  4. cb昼休み
シートモジュール

定例業務

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

原紙

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 cb作成_Click()
    Call MakeNewSheet
End Sub

Private Sub cb更新_Click()
    Call UpdateTable
End Sub

Private Sub cb中断_Click()
    Call SetInterruption
End Sub

Private Sub cb昼休み_Click()
    Call SetLunchBreak
End Sub

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

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Tb.ListRows.Count = 0 Then Exit Sub
    If Intersect(Target, Tb.ListColumns(列名.enNo).DataBodyRange) Is Nothing Then Exit Sub
    
    uf案件追加.Show
End Sub
標準モジュール
Enum 列名
    enNo = 1
    en実施内容
    en作業予定時間
    en●
    en実際作業時間
    en終了予定時刻
    en残り時間
    en終了時刻
    en予実比率
    en備考
    [_eLast]
End Enum

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 Sub SetLunchBreak()

    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
        Tb.DataBodyRange.Interior.Color = xlNone

    ' 直近の終了時刻セル。
    Dim LatestRange As Range
    Set LatestRange = Tb.ListRows(Tb.ListRows.Count).Range(列名.en終了時刻).End(xlUp)
    
        If LatestRange >= TimeValue("13:00") Then
            MsgBox "既に昼休み以降の作業を実施中です。"
            Exit Sub
        Else
            LatestRange.Offset(1) = Range("昼休開始")
        End If
    
    ' 直近の終了時刻セルの、テーブル内の行番号。
    Dim RowIndex As Long
        RowIndex = LatestRange.row - Tb.Range(1).row
    Dim ListRow As Excel.ListRow
    Set ListRow = Tb.ListRows.Add(RowIndex + 2)
        With ListRow
            .Range(列名.en実施内容) = "昼休み"
            .Range(列名.en作業予定時間) = Range("昼休時間")
            .Range(列名.en終了時刻) = Range("昼休開始") + Range("昼休時間")
            .Range.Interior.Color = RGB(240, 240, 240)
        End With
    
    Set ListRow = Tb.ListRows.Add(RowIndex + 3)
        ListRow.Range(列名.en実施内容) = Tb.ListRows(RowIndex + 1).Range(列名.en実施内容)
        ListRow.Range(列名.en作業予定時間) = Tb.ListRows(RowIndex + 1).Range(列名.en作業予定時間)
        ListRow.Range(列名.en備考) = Tb.ListRows(RowIndex + 1).Range(列名.en備考)

End Sub

Public Sub MakeNewSheet()
    Dim NewSheetName As String
        NewSheetName = Format(Date, "m月d日（aaa）")
    Dim Ws As Worksheet
        For Each Ws In Worksheets
            If Ws.Name = NewSheetName Then
                MsgBox "本日のシートは作成済みです。"
                Exit Sub
            End If
        Next

    Dim NewSheet As Worksheet
        ActiveSheet.Copy After:=ActiveSheet
    Set NewSheet = ActiveSheet
        NewSheet.Name = NewSheetName
        NewSheet.Range("終業予定") = "17:00"
    Dim Tb As ListObject
    Set Tb = NewSheet.ListObjects(1)
        Tb.Name = "Table_" & Format(Date, "yyyymmdd")
        
    Dim DeleteFlag As Boolean
    Dim i As Long
        For i = Tb.ListRows.Count To 1 Step -1
            If Tb.ListRows(i).Range(列名.en終了時刻) <> vbNullString Then
                If Not DeleteFlag Then
                    DeleteFlag = True
                    Tb.ListRows(i).Range(列名.en終了時刻) = vbNullString
                Else
                    Tb.ListRows(i).Delete
                End If
            End If
        Next
    
    Dim arr As Variant
        If Sheet0.Tb.ListRows.Count <> 0 Then
            arr = Sheet0.Tb.DataBodyRange
            For i = 1 To UBound(arr)
                Tb.ListRows.Add 1
            Next
            Tb.DataBodyRange.Cells(1, 2).Resize(UBound(arr), 2) = arr
        End If
        
    Call UpdateTable
End Sub

Sub SetInterruption()
    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    ' 現在作業中案件の終了時刻セル。
    Dim PresentRange As Range
    Set PresentRange = Tb.ListRows(Tb.ListRows.Count).Range(列名.en終了時刻).End(xlUp).Offset(1)
    
    ' 現在作業中案件のテーブル行番号。
    Dim RowIndex As Long
        RowIndex = PresentRange.row - Tb.Range(1).row
    
    ' 中断後に行う作業と、中断作業を再開するための行を一つずつ追加。
        Tb.ListRows.Add RowIndex + 1
        Tb.ListRows.Add RowIndex + 1
    
    ' 中断作業再開の項目は、現在進行中の項目から移植する。
        Tb.ListRows(RowIndex + 2).Range(2).Resize(, 2).Value = Tb.ListRows(RowIndex).Range(2).Resize(, 2).Value
    
    ' 中断する作業は、中断ボタンを押した時点で一旦終わったこととする。
    ' 入力される時間がことなる場合（事後で中断ボタンを押す場合など）は、終了時刻を手入力で修正する。
        PresentRange = wf.MRound(Time, "0:15")
    
    ' 中断後に行う実施内容をそのまま入力できるよう、該当セルを選択。
        Tb.ListRows(RowIndex + 1).Range(2).Select
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
ユーザーフォーム（uf案件追加）

※案件を全て手作業で編集する場合、これは割愛してもＯＫ。
f:id:Infoment:20210129223419p:plain
各オブジェクト名の頭に付した二文字は、以下を意味している。

  1. ｃｂ：コマンドボタン
  2. ｓｂ：スピンボタン
  3. ｔｂ：テキストボックス
  4. ｏｂ：オプションボタン
  5. ｆｇ：フラグ
Private Sub cb終了_Click()
    Unload Me
End Sub

Private Sub cb入力_Click()
    With Tb.ListRows.Add(TargetRowIndex)
        .Range(en実施内容) = tb実施内容
        .Range(en作業予定時間) = tb作業予定時間
    End With
    Unload Me
End Sub

Private Sub sb時間増減_SpinUp()
    Dim temp As Double
        temp = 数値時間
        If temp <> sb時間増減.Min Then
            temp = wf.MRound(temp - 0.25, "0.25")
            tb作業予定時間 = wf.RoundDown(temp, 0) & ":" & _
                             Format((temp - wf.RoundDown(temp, 0)) * 60, "00")
        End If
End Sub

Private Sub sb時間増減_SpinDown()
    Dim temp As Double
        temp = 数値時間
        If temp <> sb時間増減.Max Then
            temp = wf.MRound(temp + 0.25, "0.25")
            tb作業予定時間 = wf.RoundDown(temp, 0) & ":" & _
                             Format((temp - wf.RoundDown(temp, 0)) * 60, "00")
        End If
End Sub

Private Sub tb実施内容_Change()
    cb入力.Enabled = fg入力
End Sub

Private Sub UserForm_Initialize()
    tb実施内容.SetFocus
    tb作業予定時間 = "0:15"
    ob下に追加 = True
    sb時間増減.Min = 0
    sb時間増減.Max = 8
    cb入力.Enabled = fg入力
End Sub

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

Private Property Get fg入力() As Boolean
    Dim fg実施内容 As Boolean
    Dim fg作業予定時間 As Boolean
        If tb実施内容 <> vbNullString Then fg実施内容 = True
        If tb作業予定時間 <> vbNullString Then fg作業予定時間 = True
        
        fg入力 = fg実施内容 * fg作業予定時間
End Property

Private Property Get 数値時間() As Double
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.Pattern = "^(\d{1,2}):(\d{1,2})$"
    Dim MC As Object
    Dim SM As Object
        
        If myReg.test(tb作業予定時間) Then
            Set MC = myReg.Execute(tb作業予定時間)
            Set SM = MC(0).SubMatches
            数値時間 = SM(0) + SM(1) / 60
        Else
            数値時間 = 1
        End If
End Property

Private Property Get TargetRowIndex() As Long
    TargetRowIndex = Selection.row - Tb.Range(1).row
    If ob下に追加 Then
        TargetRowIndex = TargetRowIndex + 1
    End If
End Property

Private Function wf() As WorksheetFunction
    Set wf = WorksheetFunction
End Function
最後に

今後も日々使ってみて、補修したり機能拡張するなどしてみよう。
まとまったら、改めて紹介するかもしれない。

ということで、このシリーズは今回でおしまい。

参考まで。