出勤簿を作る　(3)

はじめに

　今回は社員リストから社員分の出勤簿シートを作成するプログラムを書いていきます。
　月度の変わり目に、日付や曜日を整えて、一気に社員分の出勤簿を作ってくれます。
　
　また、途中で社員が追加される場合も想定して、出勤簿シートを追加する機能も付けます。
　削除に関しては、社員リストの名前と、出勤簿シートを削除すれば良いでしょう。
　
　更にメニューシートを追加して、出勤簿の日付も設定できるようにします。
　

社員リストシート

　人数分の社員番号と、名前をリストを記録しておく社員リストシートを追加します。また、社員の追加に関しては社員リストシートにボタンを配置しておきます。

メニューシート

　メニューシートには処理年月度の設定と、説明文。加えて来月度の出勤簿を作成ボタンなどを設置します。その他ブック全体に係る操作がある場合は機能追加します。

出勤簿シートと勤務パターンシート

　前回まで「出勤簿」としていたシートは「原本」に変更して各社員分の出勤簿の原型とします。
　もし、出勤簿を変更したい場合は、原本シートを変更する事になります。

　勤務パターンシートは変更ありません。

プログラム

　今回のプログラムは全て標準モジュールに書いていきます。
　プログラムコードが長くなるので、機能別に分けても良いでしょう。
　サンプルファイルはModule1～3に分かれています。

　尚、ユーザーフォームで勤務パターンを選択するコードに関しては前回と同じなので省略します。

社員分の出勤簿の作成

　社員リストを基に社員分の出勤簿を作成するプログラムです。
　まず、原本シートの日付を変更し、その後、社員リストを巡回しながら、原本シート（出勤簿シート）をコピーしてシート名を社員名に変換しながらシートを追加していきます。

Sub 社員分の出勤簿の作成()
    Dim shName As String
    Dim sh As Worksheet
    Dim i As Long
    
    '原本の日付設定を変更
    With Worksheets("メニュー")
    Worksheets("原本").Range("B1") = DateSerial(.Range("B4"), .Range("D4"), 1)
    End With
    
    With Worksheets("社員リスト")
    
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row　　　'社員リスト分の繰り返し
      
        shName = .Cells(i, "B")
        
        On Error Resume Next
        '末尾にシート追加
        Set sh = Worksheets(shName)
        On Error GoTo 0
        
        If sh Is Nothing Then
            '同じシート名は無いので新たに作る
            Worksheets("原本").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shName
            ActiveSheet.Range("B2") = "№ " & .Cells(i, "A")
            ActiveSheet.Range("D2") = shName
        Else
            MsgBox shName & "は既にシートがあります。確認してください。"
            Exit Sub
        End If
        
        Set sh = Nothing　　　'オブジェクト変数の初期化
    
    Next i
    
    End With
End Sub

　社員名のシートが1つでもあれば、その時点でエラーメッセージを出して終了します。
　既に社員分のリストがある場合は、削除してから実行してください。

次月度の出勤簿ブックを生成

　今回の出勤簿プログラムは１カ月分を１ブックとして管理しています。
　そこで、来月分の出勤簿ブックを作りたい場合、今あるブックの情報から生成するようにします。
　
　ブックは来月用にファイル名を生成します。（例：202404出勤簿.xlsm）
　作り方の基本方針は、現在の日付を来月分に変更し、社員分の出勤簿を一旦削除してから新たに社員リストから出勤簿をコピーしていきます。

Sub 次月度の出勤簿ブックを生成()
    '次月の年と月を得る
    Dim nextY As Long, nextM As Long
    Dim nextMonthBook As String
    Dim sCurrentPath As String
    
    With Worksheets("メニュー")
    
    '次月の年、月を得る
    nextY = .Range("B4")
    nextM = .Range("D4")
    If nextM = 12 Then
        nextY = nextY + 1
        nextM = 1
    Else
        nextM = nextM + 1
    End If
    
    End With

    '確認メッセージ
    Dim result As Long
    Dim myMessage As String
    myMessage = nextY & "年" & nextM & "月の出勤簿を作成します。よろしいですか？"
    result = MsgBox(myMessage, vbYesNo + vbQuestion + vbDefaultButton2, "確認")
    
    If result = vbNo Then Exit Sub
    

    '出勤簿のファイル名を生成  （yyyymm出勤簿.xlsm）
    nextMonthBook = nextY & Format(nextM, "00") & "出勤簿" & ".xlsm"
    sCurrentPath = ActiveWorkbook.Path & "\"

    '次月度の出勤簿が存在しているかどうかのチェック
    If Dir(sCurrentPath & nextMonthBook) <> "" Then
        MsgBox "既に　" & nextMonthBook & "が存在しますので中止します。"
        Exit Sub
    End If
    
    'ブック（自分自身）をコピー
    ThisWorkbook.SaveCopyAs sCurrentPath & nextMonthBook
    
    '次月度勤務表ブックを開く
    Dim nWb
    Set nWb = Workbooks.Open(sCurrentPath & nextMonthBook)
    
    'このファイルから次月の出勤簿を作成
    '　社員のシートを削除
    Dim sh
    For Each sh In nWb.Worksheets
        If sh.Name <> "原本" _
            And sh.Name <> "社員リスト" _
            And sh.Name <> "メニュー" _
            And sh.Name <> "勤務パターン" Then
                
            Application.DisplayAlerts = False
            sh.Delete
            Application.DisplayAlerts = True
        End If
    Next sh
    
    '  新しい年、月をセットして社員分のシートを生成
    Dim i As Long, shName As String
    
    nWb.Worksheets("メニュー").Range("B4") = nextY
    nWb.Worksheets("メニュー").Range("D4") = nextM
    nWb.Worksheets("原本").Range("B1") = DateSerial(nextY, nextM, 1)
    
    With nWb.Worksheets("社員リスト")

    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row

        shName = .Cells(i, "B")
        nWb.Worksheets("原本").Copy after:=nWb.Worksheets(nWb.Worksheets.Count)
        ActiveSheet.Name = shName
        ActiveSheet.Range("B2") = "№ " & .Cells(i, "A")
        ActiveSheet.Range("D2") = shName
    Next i
    
    End With
    
    nWb.Worksheets(1).Select
    
    '新しいファイルを保存
    Workbooks(nextMonthBook).Save
    Workbooks(nextMonthBook).Close SaveChanges:=False
    
    MsgBox "翌月の出勤簿ファイルを作成しました。"
End Sub

追加社員の出勤簿作成

　このプログラムは、ボタンを社員リストシートに配置しました。
　途中で社員を追加したい場合はボタンを押せば作れるようにしておきます。

　もし、手作業で追加したい場合は、社員リストに社員番号と名前を追加して、原本をコピーした後、シート名を社員名に変更します。
　新しく追加した出勤簿シートの社員番号（B2セル）と氏名（D2セル）を入力すれば完了です。
　
　プログラムはこれと同じ作業を行っているだけです。

Sub 追加社員の出勤簿作成()
    Dim shName As String
    Dim sh As Worksheet
    Dim i As Long
    
    With Worksheets("社員リスト")
        
    For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
    
        shName = .Cells(i, "B")
        
        On Error Resume Next
        '末尾にシート追加
        Set sh = Worksheets(shName)
        On Error GoTo 0
        
        If sh Is Nothing Then
            '同じシート名は無いので新たに作る
            Worksheets("原本").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shName
            ActiveSheet.Range("B2") = "№ " & .Cells(i, "A")
            ActiveSheet.Range("D2") = shName
        Else
            '既にあれば何もしない。
        End If
        
        Set sh = Nothing
             
    Next i
    
    End With
End Sub

最後に

　今回のプログラムは社員分の出勤簿シート作成や次月のブック作成などコピー絡みのコードが中心でした。ただコピーするのではなく、同じシート名やファイル名（ブック名）が無いかを確認するなどの前処理も必要になってくるのでコードが長くなります。
　しかし、このお陰で自動化できるようになり、作業の手間がぐっと楽になりました。

　コードが長くなったといっても、順に追っていけばそれほど複雑な事をしているわけではないと感じると思います。

　次回は集計した値を出力できるようにしてみます。