個人別時給計算表を自動で作成するVBAの組み立て

Option Explicit

    Public EmpName As String, 年月日 As String
    Public OriBName As String
    Public TCos, TwCos, TMal, KMal
    Public SD As Date, ED As Variant
    Public KShH As Boolean
    Dim SaName As String, SaNamea As String

Sub 設定値代入()
    Dim MB As Long
        Worksheets("初期設定項目").Select
'会計期間をセット
        Range("D5", "F5").NumberFormatLocal = "dd"
STEP0:
        If Range("D5") = "" Then
            MsgBox "会計期間が未入力です。" & vbCrLf & "入力してください。" _
                        , vbExclamation, "時給計算表作成"
STOP1:
            On Error Resume Next
            SD = Application.InputBox("開始日を入力してください。", _
                        Title:="時給計算表作成", Type:=2)
            On Error GoTo 0
            If SD = False Then
                MsgBox "日付未入力ではテンプレート作成出来ません。", _
                            vbExclamation, "時給計算表作成"
                GoTo STOP1
            ElseIf SD = "" Then
                MsgBox "日付未入力ではテンプレート作成出来ません。", _
                            vbExclamation, "時給計算表作成"
                GoTo STOP1
            ElseIf SD < 1 Or SD > 31 Then
                MsgBox "異常値ではテンプレート作成出来ません。", _
                            vbExclamation, "時給計算表作成"
                GoTo STOP1
            Else
                With Worksheets("初期設定項目")
                    .Range("D5").Value = SD
                End With
            End If
        ElseIf Range("D5") < 1 Or Range("D5") > 31 Then
            MsgBox "異常値ではテンプレート作成出来ません。", _
                        vbExclamation, "時給計算表作成"
            Range("D5") = ""
            GoTo STEP0:
        Else
            With Worksheets("初期設定項目")
                .Range("D5").Value = SD
            End With
        End If
STEP2:
        If Range("F5") = "" Then
            MsgBox "会計期間が未入力です。" & vbCrLf & "入力してください。" _
                        , vbExclamation, "時給計算表作成"
STOP3:
            On Error Resume Next
            ED = Application.InputBox("開始日を入力してください。", _
                        Title:="時給計算表作成", Type:=2)
            On Error GoTo 0
            If ED = False Then
                MsgBox "日付未入力ではテンプレート作成出来ません。", _
                            vbExclamation, "時給計算表作成"
                GoTo STOP3
            ElseIf ED = "" Then
                MsgBox "日付未入力ではテンプレート作成出来ません。", _
                            vbExclamation, "時給計算表作成"
                GoTo STOP3
            ElseIf ED < 1 Or ED > 31 Then
                MsgBox "異常値ではテンプレート作成出来ません。", _
                            vbExclamation, "時給計算表作成"
                GoTo STOP3
            Else
                With Worksheets("初期設定項目")
                    .Range("F5").Value = ED
                End With
            End If
        ElseIf Range("F5") < 1 Or Range("F5") > 31 Then
            MsgBox "異常値ではテンプレート作成出来ません。", _
                        vbExclamation, "時給計算表作成"
            Range("F5") = ""
            GoTo STEP2:
        Else
            With Worksheets("初期設定項目")
                .Range("F5").Value = ED
            End With
        End If
        With Worksheets("初期設定項目")
            SD = .Range("D5").Value
            ED = .Range("F5").Value
        End With
'対象者名を変数に代入します
        EmpName = Worksheets("初期設定項目").Range("C6").Value
'基本時給をセット
        TCos = Worksheets("初期設定項目").Range("C7").Value
'時間外割増率をセット
        TwCos = Worksheets("初期設定項目").Range("F7").Value / 100
'時間マルメをセット
        TMal = Worksheets("初期設定項目").Range("C8").Value
'金額マルメをセット
        KMal = Worksheets("初期設定項目").Range("C9").Value
'計算シートの保存法を取得
        KShH = Worksheets("初期設定項目").Range("E10").Value
End Sub

Sub 対象者用時間計算作成()
    Dim ThisName, NewDir As String
    Dim TSY As Variant
    Dim MojiCoA As Integer
    Dim Wb As Workbook
    Dim res As Boolean
    Dim MBn, MBsa, MBtn As Long
        Call Module1.設定値代入
'Format,Year,Month関数を利用します
        年月日 = Format(Date, "yymmdd")
'対象者が空欄の場合の処理
        If Worksheets("初期設定項目").Range("C6") = "" Then
            MBn = MsgBox("対象者名が空欄ですが続けますか？", _
                vbOKCancel + vbExclamation, "時給計算表作成")
            If MBn = 1 Then
                TSY = Application.InputBox("対象者名を入力してください。" _
                            , Title:="時給計算表作成", Type:=2)
                If TSY = False Then
                    MsgBox "空欄ではデータを区別できません。" & vbCrLf & _
                            "今日の年月日を代用します。", vbExclamation, _
                            "時給計算表作成"
                    TSY = 年月日
                End If
            Else
                MsgBox "空欄ではデータを区別できません。" & vbCrLf & _
                            "今日の年月日を代用します。", vbExclamation, _
                            "時給計算表作成"
                TSY = 年月日
            End If
            With Worksheets("初期設定項目").Range("C6")
                .Value = TSY
                EmpName = .Value
            End With
        End If
'拡張子なしのファイル名を取得します
        MojiCoA = InStrRev(ThisWorkbook.Name, ".")
        ThisName = Left(ThisWorkbook.Name, MojiCoA - 1)
        ThisWorkbook.Save
'保存場所と保存ファイル名を変数へ代入します
        NewDir = ThisWorkbook.Path & "\計算メンバー"
        SaName = ThisName & "-" & EmpName & ".xlsm"
        SaNamea = ThisName & "-" & EmpName & _
                    Format(Date, "yymmdd") & ".xlsm"
'保存フォルダが既にあるかどうかを調べます
    'フォルダが存在しなければ作成します
        If Dir(NewDir, vbDirectory) = "" Then
            MkDir NewDir
        End If
'ディレクトリを変更します
        ChDir NewDir
'保存したいファイルが既に存在するかを調べます
    '存在しない場合この名前でファイルを保存します
        If Dir(SaName, vbNormal) = "" Then
            ThisWorkbook.SaveAs (SaName)
            MsgBox "ファイルを保存しました。", vbInformation, _
                        "時給計算表作成"
    '存在する場合、終了するか続けるかを選択します。
        Else
            MBtn = MsgBox("ファイルは既に存在します。" & vbCrLf _
                        & "終了しますか？", _
                   vbYesNoCancel + vbExclamation, "時給計算表作成")
        '終了する
            If MBtn = vbYes Then
                Exit Sub
        '日付付きで別ファイルとして保存
            ElseIf MBtn = vbNo Then
                MsgBox "日付付きで保存します。", vbInformation, _
                            "時給計算表作成"
                ThisWorkbook.SaveAs (SaNamea)
            ElseIf MBtn = vbCancel Then
                MsgBox "終了します。", vbInformation, "時給計算表作成"
                Exit Sub
            End If
        End If
'対象者名をファイル名と一致させるためのマーカーをつくる
        With Worksheets("初期設定項目").Range("H5")
            .Value = Worksheets("初期設定項目").Range("C6")
            .Font.ColorIndex = 2
        End With
        Call Module1.計算Bookコマンド削除
End Sub

Sub 計算Bookコマンド削除()
    Dim CommButton As Object
        OriBName = "時給計算表.xlsm"
'テンプレートファイルであれば終了します
        If ThisWorkbook.Name = OriBName Then
            Exit Sub
        Else
'「対象者計算Book作成」ボタンだけを削除します
            For Each CommButton In Worksheets("初期設定項目").Shapes
                If CommButton.Name = "対象者計算Book作成" Then
                    Worksheets("初期設定項目").Shapes(CommButton.Name).Delete
                    Exit Sub
                End If
            Next
        End If
End Sub

Sub ブックを保存()
    Dim OpBook As Workbook
        For Each OpBook In Workbooks
            OpBook.Save
        Next
'エクセルを終了します
        Application.Quit
End Sub