【クリ8】Excel地獄を終わらせる生産計画連動シフト管理ツール

Private Sub Workbook_BeforeClose(Cancel As Boolean)


    ' 現在開いているファイルを自動保存する
    ThisWorkbook.Save

    ' メッセージを表示する
    MsgBox "ファイルが保存されました。", vbInformation, "保存完了"


End Sub

Sub 印刷()

    ActiveSheet.PrintOut

End Sub

Sub 氏名更新()

    Dim wsA As Worksheet, wsB As Worksheet

    Set wsA = ThisWorkbook.Worksheets("休暇希望")
    Set wsB = ThisWorkbook.Worksheets("出勤表")

    wsA.Range("C4:C53").Copy
    wsB.Range("K9").PasteSpecial xlPasteValues

    wsA.Range("B4:B53").Copy
    wsB.Range("I9").PasteSpecial xlPasteValues

End Sub

Sub 休暇希望リセット()

    Dim wsA As Worksheet

    Set wsA = ThisWorkbook.Worksheets("休暇希望")

    wsA.Range("E4:AI53").ClearContents

End Sub

Sub 出勤人数を調査()

    Dim searchDate As String
    Dim gyou As String
    Dim jikan As String
    Dim retu As Integer
    Dim i As Integer, x As Integer, y As Integer
    Dim mojisu As Integer

    searchDate = Format(Date, "yyyy/mm/dd") ' 今日の日付を取得

    ' 今日の日付が含まれる列を検索
    For i = 13 To 44
        gyou = Worksheets("出勤表").Cells(7, i)
        If gyou = searchDate Then
            retu = i
            Exit For
        End If
    Next i

    ' 出勤人数をカウント
    For x = 9 To 58
        jikan = Worksheets("出勤表").Cells(x, retu)
        mojisu = Len(jikan)

        If Worksheets("出勤表").Cells(x, 11) <> "" Then
            If mojisu > 4 Then
                jikan = ""
            End If
            If jikan = "" Then
                y = y + 1
            End If
        End If
    Next x

    MsgBox "　今日の出勤人数は " & y & " 名です"

End Sub

Sub 作業計画の人時更新()

    Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
    Dim i As Integer, j As Integer
    Dim lastRowA As Long, lastRowC As Long
    Dim dateA As Variant, dateC As Variant

    ' シートの設定
    Set wsA = ThisWorkbook.Worksheets("出勤表")
    Set wsB = ThisWorkbook.Worksheets("作業計画")
    Set wsC = ThisWorkbook.Worksheets("各種設定")

    ' 出勤表のBY9:BY39の値を作業計画シートD7から貼り付け
    wsA.Range("BY9:BY39").Copy
    wsB.Range("D7").PasteSpecial xlPasteValues

    ' 作業計画シートで、列Eが空欄の場合、列Dをクリア
    For i = 7 To 37
        If wsB.Cells(i, 5).Value = "" Then wsB.Cells(i, 4).ClearContents
    Next i

    ' 各種設定シートの最終行を取得
    lastRowC = wsC.Cells(wsC.Rows.Count, 1).End(xlUp).Row

    ' 作業計画シートのA列の範囲
    For i = 7 To 37
        dateA = wsB.Cells(i, 1).Value ' 作業計画シートの日付
        If Not IsEmpty(dateA) Then
            ' 各種設定シートのA列を検索
            For j = 4 To lastRowC
                dateC = wsC.Cells(j, 1).Value ' 各種設定シートの日付
                If dateA = dateC Then
                    ' 一致する場合、作業計画シートのD～J列をクリア
                    wsB.Range(wsB.Cells(i, 4), wsB.Cells(i, 10)).ClearContents
                End If
            Next j
        End If
    Next i

End Sub

Sub 計算式再入力()

    Dim ws As Worksheet
    Dim rowNum As Long

    ' シート「作業計画」を指定
    Set ws = ThisWorkbook.Sheets("作業計画")

    ' 7行目から37行目をループ
    For rowNum = 7 To 37
        ' E列の計算式を設定
        ws.Cells(rowNum, "E").Formula = "=IFERROR(H" & rowNum & "+J" & rowNum & "+L" & rowNum & "+N" & rowNum & "+P" & rowNum & "+R" & rowNum & "+T" & rowNum & "+V" & rowNum & "+X" & rowNum & "+Z" & rowNum & "+AB" & rowNum & "+AD" & rowNum & "+AF" & rowNum & "+AH" & rowNum & ", """")"

        ' F列の計算式を設定
        ws.Cells(rowNum, "F").Formula = "=IFERROR(D" & rowNum & "-E" & rowNum & ", """")"

        ' G列の計算式を設定
        ws.Cells(rowNum, "G").Formula = "=SWITCH($C" & rowNum & ", ""月"", $AQ$1, ""火"", $AQ$2, ""水"", $AQ$3, ""木"", $AQ$4, ""金"", $AQ$5, ""土"", """", ""日"", """")"

        ' H列の計算式を設定
        ws.Cells(rowNum, "H").Formula = "=IFERROR(G" & rowNum & "/30, """")"

        ' I列の計算式を設定
        ws.Cells(rowNum, "I").Formula = "=SWITCH($C" & rowNum & ", ""月"", $AS$1, ""火"", $AS$2, ""水"", $AS$3, ""木"", $AS$4, ""金"", $AS$5, ""土"", """", ""日"", """")"

        ' J列の計算式を設定
        ws.Cells(rowNum, "J").Formula = "=IFERROR(I" & rowNum & "/30, """")"
    Next rowNum

    MsgBox "各計算式の入力が完了しました！", vbInformation

End Sub