2021-02-08

セルの値を合計するマクロ

Excel VBA ユーザー定義関数作ってみた

↓ こちらが面白い。
www.atmarkit.co.jp

中でも、登場人物のこの会話が楽しくて好きだ。
「セルの値を合計するマクロができたぞ……！」
「そういう再発明もたまにはいいですよね」

ということで、私もセルの値を合計するマクロを作ってみた。
f:id:Infoment:20210208224714p:plain

この飛び飛びの範囲で、足し算してみよう。
f:id:Infoment:20210208224953p:plain

ちなみに、通常であればSUM関数による瞬殺案件だ。
f:id:Infoment:20210208225106p:plain

↑ 御覧のように、指定範囲に含まれる文字は無視して、数字だけを加算している。

今回は、数が決まっていない複数の範囲を指定されることを想定し、引数を
可変長にしてみた。
docs.microsoft.com

また、文字を足し算するとエラーになることから、今回はナマクラしてエラーを
無視させてみた（On Error Resume Next）。

Function 合計(ParamArray target_range() As Variant) As Double
    Dim Area As Variant
    Dim Cell As Variant
        On Error Resume Next
        For Each Area In target_range
            For Each Cell In Area
                合計 = 合計 + Cell
            Next
        Next
        On Error GoTo 0
End Function

本家のSUM関数と同じ結果を返してくれた。今のところ、問題なさそうだ。
f:id:Infoment:20210208225706p:plain

ということで、これを職場の勉強会に持ち込んでみたのだが、テーマとして
実は難度が結構高いことが分かった。

普段、ParamArrayに馴染みが無い。
二重ループは、学び始めの方にはイメージしにくい。
エラーって無視していいのか。
無視しないなら、足していいかをどう確認するか。
Areasプロパティに話が及ぶ。
などなど。

結果、中級者を対象とした勉強会のテーマにすると、色々と学ぶことが多くて
面白いかも？と思った次第です。

参考まで。

2021-02-04

二回宣言すると怒られる

Excel VBA

Excel VBA では、同じ変数を二回宣言すると怒られる。
f:id:Infoment:20210204222055p:plain

例えば、こんな感じだ。
f:id:Infoment:20210204222132p:plain

変数の型を変えても、見逃してはもらえない。
f:id:Infoment:20210204222229p:plain

ところが先日、自分では意図せず、このように宣言したものが
あることに気づいた。
f:id:Infoment:20210204222346p:plain

片方は、モジュールレベル変数。同一モジュール内であれば、
共通の変数として使用できる。

もう一つは、宣言したサブプロシージャ内でのみ有効な変数だ。

なぜかどこかで何時からか、このような変数宣言もシステムから
咎められるものと思い込んでいた。しかしこれが許されるならば、
その挙動をきちんと理解しておかないと事故につながりそうだ。

例えば、こんなのはどうだろう。
f:id:Infoment:20210204222832p:plain

Test1とTest2のそれぞれで宣言した変数ｉは、同じ名前の変数では
あるが、宣言した場所が違うため別物として扱われる。従って、
Test1は呼び出されるたびにｉが宣言し直され（仕切り直され）る
ため、ｉは２以上になることはない（初期値０なので、０＋１＝１）。
f:id:Infoment:20210204223245p:plain

この結果は、モジュールレベル変数が存在した場合も同じだった。
（プロシージャ内で宣言された変数が優先される）。
f:id:Infoment:20210204223318p:plain

では、Test1内の宣言を省くとどうなるか。
f:id:Infoment:20210204223412p:plain

この場合、モジュールレベル変数ｉとしてカウントアップされるため、
最初とは異なる結果となった。
f:id:Infoment:20210204223517p:plain

逆にTest2側の場合は、単にループカウンタとしてカウントアップされる
だけなので、この場合は影響なしだった（たまたま）。
f:id:Infoment:20210204223631p:plain

それでは、両方省くとどうなるか。
f:id:Infoment:20210204223705p:plain

Test1 と Test2 の変数ｉは、どちらも同じものが使われるため、このような
結果となった。
f:id:Infoment:20210204223855p:plain

あな恐ろしや。誤動作防止のためにも、変数宣言は極力プロシージャ
単位で行った方がよさそうです。

参考まで。

2021-01-31

昔のアニメ映画の予告編みたいな文字送り

VBA Excel

今も印象深く心に残っているのが、小学生の時に見たアニメ映画
「幻魔大戦」
の劇場予告編だ。

↓ ※音が出たらマズイ人は、ご注意ください。
youtu.be

この「幻魔大戦」の４文字の出し方が、子供ながらに格好良いと
思った。そこで今回は、これをExcel で疑似的に再現してみよう。
f:id:Infoment:20210131230716p:plain

今回はワードアートを使った文字で、等間隔に並べてみることにした。
それっぽいフォント名やサイズで、まず決め打ちで作ってみた。

Function WardArt(display_characters As String) As Excel.Shape
    Set WardArt = ActiveSheet.Shapes.AddTextEffect(PresetTextEffect:=msoTextEffect45, _
                                                 Text:=display_characters, _
                                                 FontName:="+mn-lt", _
                                                 FontSize:=54, _
                                                 FontBold:=msoTrue, _
                                                 FontItalic:=msoFalse, _
                                                 Left:=0, _
                                                 Top:=0)
        With WardArt.TextFrame2.TextRange.Font
            .NameComplexScript = "HGSｺﾞｼｯｸE"
            .NameFarEast = "HGSｺﾞｼｯｸE"
            .Name = "HGSｺﾞｼｯｸE"
        End With
End Function

これまた決め打ちで、文字を並べてみた。

Sub 幻魔大戦()

    ' 表示する文字。
    Dim waArr() As Excel.Shape
    ReDim waArr(4, 5)
    
    ' 縦並びのループカウンタ。
    Dim i As Long
    ' 横並びのループカウンタ。
    Dim j As Long
    ' 文字用のループカウンタ。
    Dim k As Long
    
    ' 表示する文字列。
    Dim TextArray As Variant
        TextArray = Array("幻", "魔", "大", "戦")
        
        ' 「幻」の文字を等間隔に表示。
        ' ３行２列目だけ赤に。
        For j = 0 To 5
            For i = 0 To 4
                Set waArr(i, j) = WardArt(CStr(TextArray(0)))
                    waArr(i, j).Top = i * 60
                    waArr(i, j).Left = j * 60
                    If i = 2 And j = 1 Then
                        waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(192, 0, 0)
                    End If
            Next
            
            ' １列毎に少し止める。
            Application.Wait [Now() + "00:00:00.3"]
        Next
        
        ' セットした文字を、「魔・大・戦」の順に入れ替えていく。
        ' ただし、赤色の文字はそのままにしておく。
        ' 「幻魔大戦」が中央に書かれるよう、赤い文字の後ろは赤に。
        For k = 1 To 3
            For j = 0 To 5
                For i = 0 To 4
                    If waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB <> RGB(192, 0, 0) Then
                        waArr(i, j).TextFrame2.TextRange.Characters.Text = TextArray(k)
                    End If
                    If i = 2 And j = k + 1 Then
                        waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(192, 0, 0)
                    End If
                Next
                Application.Wait [Now() + "00:00:00.3"]
            Next
        Next
        
        ' 赤以外の文字は消す。
        Application.Wait [Now() + "00:00:01"]
        For j = 0 To 5
            For i = 0 To 4
                If waArr(i, j).TextFrame2.TextRange.Font.Fill.ForeColor.RGB <> RGB(192, 0, 0) Then
                    waArr(i, j).Delete
                End If
            Next
        Next
End Sub

結果がこちら。
f:id:Infoment:20210131231550g:plain

それなりに、それっぽくなったかな。
決め打ち部分をもう少し工夫すれば、汎用的に使えるかも。

参考まで。

2021-01-29

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

Excel VBA

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

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

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

シートについて

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

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

定例業務には、「定例業務テーブル」を作成。
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

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

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

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

cb作成
cb更新
cb中断
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
各オブジェクト名の頭に付した二文字は、以下を意味している。

ｃｂ：コマンドボタン
ｓｂ：スピンボタン
ｔｂ：テキストボックス
ｏｂ：オプションボタン
ｆｇ：フラグ

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

最後に

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

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

参考まで。

2021-01-25

スケジュール管理表を作成 ⑨ 実行中の作業を中断

Excel VBA

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

f:id:Infoment:20210125220333p:plain

例えば、こんな予定を立てていたとする。
f:id:Infoment:20210125222551p:plain

ところが「●●ユニット」を構想し始めて30分経った頃、上司からの指示で
打ち合わせを行うことになった。この時、スケジュールとしては、

① 一旦、●●ユニットの構想を終了。終了時刻は9:30。
f:id:Infoment:20210125223149p:plain

② 今から行う打ち合わせを追加。
f:id:Infoment:20210125223247p:plain

③ 打ち合わせ後に再開予定の構想を追加。
f:id:Infoment:20210125223414p:plain

この作業が地味に面倒くさいので、「中断」ボタンを設けることにした。
ついでに、残り時間などの再計算を行うための「更新」ボタンも追加した。
f:id:Infoment:20210125223525p:plain

コマンドボタンのオブジェクト名

中断ボタン　cb中断
更新ボタン　cb更新

↓ シートモジュールに記載。

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

Private Sub cb中断_Click()
    Call SetInterruption
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

さてそれでは、部長と打ち合わせのため席を立つところを再現してみよう。
f:id:Infoment:20210125224158g:plain

この操作を録画した時刻が23時前であるため、中断した時刻が9:30ではなくなって
いるが、意図したことは伝わっただろうか。

ということで、本日はここまで。
次回は、総まとめを行います。

参考まで。

2021-01-21

スケジュール管理表を作成 ⑧ 前日の続きからシート作成

Excel VBA

先日から、スケジュール管理表をExcelで作成している。
infoment.hatenablog.com
今日も、前回の続きから。
f:id:Infoment:20210121222700p:plain
例えば、こんな感じで一日を終えたとする。
f:id:Infoment:20210121222850p:plain
この日最後に終えた案件Ｆについて、実は二通りのパターンがある。

きっちり最後まで終えて帰宅した。
志半ばで時間切れ。翌日朝から仕切り直しだ。

そこで、翌日のシートを作成するとしたら、仕切り直しパターンを想定して
前日最後の仕事から始めたほうがよさそうだ。

↓ 翌日。
f:id:Infoment:20210121223248p:plain

また、毎朝の定例業務がある場合は、それも差し込んでおきたい。専用の
テーブルを作成するとしよう。

↓ 定例業務シート。
f:id:Infoment:20210121223401p:plain

↓ 定例業務テーブル。
f:id:Infoment:20210121223450p:plain

それでは、前日シートから当日シートを作成する「作成」ボタンを作成しよう。
（ややこしい）。
f:id:Infoment:20210121223810p:plain
ボタンのオブジェクト名は「cb作成」とした。

↓ シートモジュール。

Private Sub cb作成ボタン_Click()
    Call MakeNewSheet
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
    
    ' 定例業務追加（定例業務シートをSheet0とし、定例業務テーブルをTbとした）。
    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

それでは、実際に作成してみよう。
f:id:Infoment:20210121224250g:plain

想定通り、朝一番を定例業務からスタートし、次いで前日のやり残し再開となる
スケジュール表を作成することが出来た。

ということで、今回はここまで。
次回は、実行中の作業を中断する場合の機能追加に挑戦です。
（本シリーズ最終回まで、あと二回ぐらい）。

参考まで。

2021-01-18

スケジュール管理表を作成 ⑦ 案件追加用フォーム作成

Excel VBA

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

例えば、実施内容のＣとＤの間に、新たな案件を追加したいとする。
f:id:Infoment:20210118230218p:plain

現状は、行を挿入したうえで実施内容と作業予定時間の入力を、それぞれ
手入力で行う必要がある。
f:id:Infoment:20210118230357p:plain

ここで少しでも手間を減らしたいので、案件追加用フォームを作成する
ことにした。

まず、フォームの起動はNo列（＝Ａ列）を選択した際に行うとしよう。
↓ シートモジュール。

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

次いで、ユーザーフォーム（上記の「uf案件追加」）を準備する。
f:id:Infoment:20210118230747p:plain

なお、ユーザーフォーム上の各オブジェクト名は下記のとおり。

tb実施内容　　：実施内容入力用テキストボックス
tb作業予定時間：作業予定時間入力用テキストボックス
sb時間増減　　：15分単位で入力時間を増減するスピンボタン
ob上に追加　　：選択セルの上の行に案件追加
ob下に追加　　：選択セルの下の行に案件追加
cb入力　　　　：案件入力ボタン
cb終了　　　　：このフォームを閉じるボタン

まず、以下のプロパティを準備。
※以降、全てユーザーフォームモジュールに記載。

① 入力ボタンを押して良いかどうかのフラグ。
　入力条件がそろって初めて、Trueになる。

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

② 時分秒を、数値にする。
　例えば１時間半「1:30」を、「1.5」にする。

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 Property Get Tb() As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
End Property

以上を踏まえたうえで、起動時の初期化を行う。
※個人的に、最も頻度が高いと思う値を設定している。
※スピンボタンが０～８なのは、１日８時間労働の場合を想定。
※最初は入力ボタンを無効化しておく（実施内容未記載なので）。

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

実施内容の入力状況と、入力ボタンを押せるか否かを連動させる。

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

スピンボタンの増減で、15分（＝0.25時間）単位で作業予定時間を増減させる。

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

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 cb入力_Click()
    With Tb.ListRows.Add(TargetRowIndex)
        .Range(en実施内容) = tb実施内容
        .Range(en作業予定時間) = tb作業予定時間
    End With
    Unload Me
End Sub

Private Sub cb終了_Click()
    Unload Me
End Sub

それでは、動作を確認してみよう。
案件Ｃと案件Ｄの間に（つまり案件Ｃの下に）、案件Ｊを追加する。
作業予定時間は、45分とする。
f:id:Infoment:20210118233120g:plain

一応、想定した動作を実現することが出来た。
ただし短縮時間は数秒であり、効果は未知数だ（自己満足の世界？）。

ということで、今回はこままで。
次回は、翌日の朝一番に行うシート準備機能の作成に挑戦です。

参考まで。