簡易的な出勤簿入力システムです。

はじめに
勤務表シート（原本）
メニューシート
プログラムコード
最後に
1. 関連記事:

はじめに

　簡易的な勤務表入力システムです。従業員、曜日を指定すると該当する出勤時間、退勤時間等を入力できるようにしてみます。ユーザーフォームなどは使わずに従業員名の勤務シートとメニューシートのみでプログラミングしてみます。

勤務表シート（原本）

勤務表（原本）は以下のようなフォーマットです。

　A列の日付は、29日以降に小の月を処理できるよう、日付を取得して28より小さい場合は空白にします。
　A32セル　=IF(DAY($A$31+1)<28,””,$A$31+1)
　A33セル　=IF(DAY($A$31+2)<28,””,$A$31+2)
　A34セル　=IF(DAY($A$31+3)<28,””,$A$31+3)

曜日の設定は、左の日付を参照して、セルの書式設定で表示させています。

　このシートに「原本」という名前を付けて保存します。このシートから従業員分の勤務表シートをプログラミングでコピーしていきます。

メニューシート

メニューシートは以下のようなフォーマットです。

　B2,D2セルで月次を設定し、H列に従業員名のリストを配置します。（何行でもOKです。）
月次シート作成ボタンで従業員分のシートを作成。

　B7～B15に該当する値を入れて、データ入力ボタンを押すと、従業員の該当する曜日に始業時間以下を転記していきます。

プログラムコード

　プログラムコードは全て標準モジュールに書きます。

Sub 月次シート作成()
    Dim i As Long
    Dim sh
    Dim lastRow As Long
    
    With Worksheets("menu")
    
    lastRow = .Cells(Rows.Count, "H").End(xlUp).Row
    
    Worksheets("原本").Range("A1") = DateSerial(.Range("B2"), .Range("D2"), 1)
    
    For i = 3 To lastRow
    
        Worksheets("原本").Copy after:=Sheets(Sheets.Count)
        
        On Error GoTo LabelError    '既に従業員シートがあれば終了
        
        ActiveSheet.Name = .Cells(i, "H")
        ActiveSheet.Range("G1") = .Cells(i, "H")
        On Error GoTo 0
    Next i
    
    End With
    
    MsgBox "正常終了"

    Exit Sub
LabelError:
    MsgBox "従業員シートが重複しています。"
End Sub

Sub データ入力()
    Dim sh As Worksheet
    Dim myName As String
    
    On Error GoTo LabelError    '該当する従業員シートが無ければ終了
    
    myName = Worksheets("menu").Range("B7")
    Set sh = Worksheets(myName)
    
    On Error GoTo 0
    
    With Worksheets("menu")
    
    Dim i As Long
    
    For i = 4 To 34
        If sh.Cells(i, "B").Text = .Range("B9") Then '曜日が同じなら
            sh.Cells(i, "C") = .Range("B10")
            sh.Cells(i, "D") = .Range("B11")
            sh.Cells(i, "E") = .Range("B12")
            sh.Cells(i, "F") = .Range("B13")
            sh.Cells(i, "G") = .Range("B14")
            sh.Cells(i, "H") = .Range("B15")
        
        End If
    Next i
    
    End With
    
    MsgBox "正常終了"
    
    Exit Sub
LabelError:
    MsgBox "従業員のシートが見つかりません。"
End Sub

Sub 集計()
    Dim sh As Worksheet
    
    On Error Resume Next
    
    Set sh = Worksheets("集計")
    
    On Error GoTo 0
    
    If sh Is Nothing Then
        '末尾にシート追加
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = "集計"
        Set sh = ActiveSheet
    End If
      
    sh.Cells.ClearContents
    
    Dim mySh
    Dim i As Long
    i = 2
    sh.Cells(1, "A") = "氏名"
    sh.Cells(1, "Ｂ") = "時間合計"
    
    For Each mySh In Worksheets
        If mySh.Name <> "menu" And mySh.Name <> "原本" And mySh.Name <> "集計" Then
            sh.Cells(i, "A") = mySh.Range("G1")
            sh.Cells(i, "B") = mySh.Range("F35")
            i = i + 1
        End If
    Next mySh
      
      
    MsgBox "終了"
End Sub