'========================================================================================= ' 495 実働日数集計表 '----------------------------------------------------------------------------------------- '【ヒント】 ' このマクロは、おためし機能の動作用のコードです。 ' Module2シートのマクロが、タイトル機能のコードです。 '========================================================================================= ' ◆標準モジュールのコード◆ '----------------------------------------------------------------------------------------- '----------------------------------------------------------------------------------------- Sub おためしマクロ() 休日表から実働日数を計算する '★★★ End Sub '----------------------------------------------------------------------------------------- Sub Auto_Close() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close '現在開いているブックを閉じる End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ★ おまかせ実働日数計算 V2.0 ★ Copyright(c)1998-2000 Yoshioh Nagai '========================================================================================= Option Explicit Dim メッセージ As String Dim タイトル As String Dim 日付入力キャンセル As Integer Dim 日付入力中の予期せぬエラー As Integer Dim 日付最小エラー As Integer Dim 日付最大エラー As Integer Dim 日付逆転エラー As Integer Dim 制限月数エラー As Integer Dim 最小YM As String Dim 最大YM As String Dim 開始年月日 As String Dim 開始年 As String Dim 開始月 As String Dim 開始日 As String Dim 開始YM As String Dim 開始YMD As String Dim 終了年月日 As String Dim 終了年 As String Dim 終了月 As String Dim 終了日 As String Dim 終了YM As String Dim 終了YMD As String Dim 月数 As Integer Dim 年月 As String Dim 年月日 As String Dim 見出年月 As String Dim 貼付行 As Integer Dim 下 As Variant Dim 列 As Integer Dim 行 As Integer Dim 色 As Variant '========================================================================================= Sub 休日表から実働日数を計算する() On Error GoTo エラー処理 '予期せぬエラーへの対策 Sheets("休日表").Select '休日表シートの Range("A1").Select 'A1セルを選択する Application.ScreenUpdating = False '画面を更新しない Sheets("結果").Range("A5:A17").ClearContents '結果シートのA5〜A17セルの数式と値をクリア 休日表の年と月の列を年月シートに写して6桁の年月を算出する On Error GoTo 0 '予期せぬエラー対策を解除 開始日と終了日を入力する If 日付入力中の予期せぬエラー = 1 Then GoTo エラー処理 End If If 日付入力キャンセル = 1 Then '開始日と終了日の入力でキャンセルボタンが押されたら タイトル = "キャンセルボタンが押されました" メッセージ = "作業を中止します。" MsgBox メッセージ, vbCritical, タイトル 'メッセージボックスで知らせる Sheets("休日表").Select Range("A1").Select Exit Sub '作業を中止する ElseIf 日付最小エラー = 1 Then '日付最小エラーなら タイトル = "開始年月が年月表の最小年月より小さい" GoTo 日付エラー処理 '日付エラー処理へ行く ElseIf 日付最大エラー = 1 Then '日付最大エラーなら タイトル = "終了年月が年月表の最大年月より大きい" GoTo 日付エラー処理 ElseIf 日付逆転エラー = 1 Then '日付逆転エラーなら タイトル = "開始年月日が終了年月日より大きいか等しい" GoTo 日付エラー処理 ElseIf 制限月数エラー = 1 Then '制限月数エラーエラーなら タイトル = "開始年月と終了年月の間が13カ月を超えてます" GoTo 日付エラー処理 End If On Error GoTo エラー処理 '予期せぬエラーへの対策 指定された範囲の年月のデータを休日表から抜出シートへ写す 年月シートの年月と抜出シートの日から年月日を作って合成シートに記入する 合成シートの年月日が指定範囲内のものを判別シートに記入する Sheets("結果").PrintPreview 'ブレビューする On Error GoTo 0 '予期せぬエラー対策を解除 Sheets("Title").Select Exit Sub '正常終了する '----------------------------------------------------------------------------------------- 日付エラー処理: タイトル = "エラー： " & タイトル メッセージ = "作業を中止します、やり直してください" MsgBox メッセージ, vbExclamation, タイトル 'メッセージボックスで知らせる Sheets("休日表").Select Range("A1").Select Exit Sub '作業を中止する '----------------------------------------------------------------------------------------- エラー処理: 'エラーが発生した時の入り口 タイトル = "予期せぬエラーが発生しました ... " & Str(Err) & ": " & Error(Err) メッセージ = "作業を中止します。原因を取り除いてから、やり直してください。" MsgBox メッセージ, vbCritical, タイトル Sheets("休日表").Select Range("A1").Select End Sub '----------------------------------------------------------------------------------------- Private Sub 休日表の年と月の列を年月シートに写して6桁の年月を算出する() Sheets("年月").Select '年月シートを Cells.Clear 'すべてクリアする Sheets("休日表").Select '休日表シートの Columns("A:B").Copy '年月の列をコピーする Sheets("年月").Select '年月シートに Range("A1").PasteSpecial Paste:=xlValues '値を貼り付ける '年と月をつないだ文字列を作る式を年月シートのセルに埋め込む Range("C2").FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])-1)" '月の数字部分を取り出す式 Range("D2").FormulaR1C1 = "=LEFT(RC[-3],4)" '年の数字部分を取り出す式（最初の行だけ） Range("C2").Copy 'C2セルをコピーする Range("C4").PasteSpecial Paste:=xlFormulas 'C4セルヘ式を貼り付ける Range("D4").FormulaR1C1 = "=IF(RC[-3]="""",R[-2]C,LEFT(RC[-3],4))" '年の数字部分を取り出す式 Range("E2").FormulaR1C1 = "=RC[-1] & RIGHT(""00"" & RC[-2],2)" '年と月をつなぐ式 Range("E2").Copy 'E2セルをコピーする Range("E4").PasteSpecial Paste:=xlFormulas 'E4セルヘ式を貼り付ける Sheets("休日表").Select '休日表シートの 下 = Range("C2").End(xlDown).Row '1日の列で下端を検出する（年月シートの下端でもある） Sheets("年月").Select '年月シートの Range("C4:E5").Copy 'C4〜E5セルまで2行分をコピーする Range(Cells(6, 3), Cells(下, 5)).PasteSpecial Paste:=xlFormulas 'C6からE列の最下端行セルまで式を貼り付け 最小YM = Range("E2").Value '入力年月のチェック用 最大YM = Range(Cells(下 - 1, 5), Cells(下 - 1, 5)).Value End Sub '----------------------------------------------------------------------------------------- Private Sub 開始日と終了日を入力する() 日付入力中の予期せぬエラー = 0 '日付入力中の予期せぬエラーフラグをリセットする On Error GoTo 日付入力中の予期せぬエラー処理 '予期せぬエラーへの対策 日付入力キャンセル = 0 'キャンセルボタン用フラグをリセット メッセージ = "1999/1/1のように入れてください" & Chr(13) & "休日表の最小年月は " & 最小YM & "です" タイトル = "開始年月日は？" 開始年月日 = Application.InputBox(prompt:=メッセージ, Title:=タイトル) 'インプットボックスで入力 If 開始年月日 = "" Then 'キャンセルボタンが押された時は 日付入力キャンセル = 1 'キャンセルボタン用フラグをセットする Exit Sub 'このプロシージャーを出る End If 開始年 = Right("0000" & Year(開始年月日), 4) '入力された年月日から年を取り出して開始年とする 開始月 = Right("00" & Month(開始年月日), 2) '月を取り出して開始月とする 開始日 = Right("00" & Day(開始年月日), 2) '日を取り出して開始日とする 開始YM = 開始年 & 開始月 '年と月をつないで開始YMとする 開始YMD = 開始年 & 開始月 & 開始日 '年と月と日ををつないで開始YMDとする If 開始YM < 最小YM Then '開始年月が最小年月より小さいか 日付最小エラー = 1 '日付最小エラーフラグをセットする Exit Sub Else 'そうでないなら 日付最小エラー = 0 '日付最小エラーフラグをリセットする End If Sheets("結果").Range("B1").Value = 開始YMD '結果シートの開始年月日に記入する ' メッセージ = "2000/12/31のように入れてください" & Chr(13) & "休日表の最大年月は " & 最大YM & "です" タイトル = "終了年月日は？" 終了年月日 = Application.InputBox(prompt:=メッセージ, Title:=タイトル) If 終了年月日 = "" Then 日付入力キャンセル = 1 Exit Sub End If 終了年 = Right("0000" & Year(終了年月日), 4) 終了月 = Right("00" & Month(終了年月日), 2) 終了日 = Right("00" & Day(終了年月日), 2) 終了YM = 終了年 & 終了月 終了YMD = 終了年 & 終了月 & 終了日 If 終了YM > 最大YM Then '終了年月が最大年月より大きいか 日付最大エラー = 1 '日付最大エラーフラグをセットする Exit Sub Else 日付最大エラー = 0 End If If 開始YMD >= 終了YMD Then '開始年月日が終了年月日より大きいか等しいか 日付逆転エラー = 1 '日付逆転エラーフラグをセットする Exit Sub Else 日付逆転エラー = 0 End If 月数 = 0 + Val(終了月) - Val(開始月) + (Val(終了年) - Val(開始年)) * 12 If 月数 > 12 Then 制限月数エラー = 1 '制限月数エラーフラグをセットする Exit Sub Else 制限月数エラー = 0 End If Sheets("結果").Range("B2") = 終了YMD '結果シートの終了年月日に記入する On Error GoTo 0 '日付入力中の予期せぬエラー対策を解除 Exit Sub ' 日付入力中の予期せぬエラー処理: 日付入力中の予期せぬエラー = 1 '日付入力中の予期せぬエラーフラグをセットする End Sub '----------------------------------------------------------------------------------------- Private Sub 指定された範囲の年月のデータを休日表から抜出シートへ写す() Sheets("抜出").Select '抜出シートを Cells.Clear 'すべてクリアする 貼付行 = 2 '貼り付けるための行カウンタに2をセットする For 行 = 2 To 下 - 1 Step 2 '2行から年月シートの下端行-1まで2行間隔で 年月 = Sheets("年月").Cells(行, 5).Value '年月シートから年月を取り出す If 年月 >= 開始YM And 年月 <= 終了YM Then '年月が開始年月と終了年月以内なら Sheets("休日表").Select '休日表の Range(Cells(行, 1), Cells(行 + 1, 33)).Copy '同じ行と次の行のA〜AG列をコピー Sheets("抜出").Select '抜出シートの Range(Cells(貼付行, 1), Cells(貼付行, 1)).PasteSpecial Paste:=xlAll '同行へすべて貼り付け Cells(貼付行, 1) = Sheets("年月").Cells(行, 5).Value '同行のA列へ年月シートの年月を写す 見出年月 = Left(年月, 4) & "年" & Right(年月, 2) & "月" '見出用の年月を作る Sheets("結果").Cells(貼付行 / 2 + 4, 1).Value = 見出年月 '結果シートのA列に見出年月を記入 貼付行 = 貼付行 + 2 '貼付行カウンタに2を加える End If Next '最終行まで繰り返す Sheets("休日表").Select Range("A1").Select End Sub '----------------------------------------------------------------------------------------- Private Sub 年月シートの年月と抜出シートの日から年月日を作って合成シートに記入する() Sheets("合成").Select '合成シートを Cells.Clear 'すべてクリアする Sheets("抜出").Select '抜出シートを Range("A1:AG27").Copy 'コピーして Sheets("合成").Select '合成シートに Range("A1").PasteSpecial Paste:=xlAll 'すべて貼り付ける Range("C2:AG27").ClearContents 'C2〜AG27セルの数式と値をクリアする '年と月をつないだ文字列を作る式を合成シートのセルに埋め込む Range("C2").FormulaR1C1 = _ "=IF(抜出!RC="""","""",RC1 & RIGHT(""00"" & 抜出!RC,2))" 'C2セルに式を記入 Range("C2").Copy 'C2セルをコピーして Range("D2:AG2").PasteSpecial Paste:=xlFormulas 'D2〜AG2セルに式を貼り付ける Range("C2:AG3").Copy 'C2〜AG3セルをコピーして Range("C4:AG27").PasteSpecial Paste:=xlFormulas 'C4〜AG27セルに式を貼り付ける End Sub '----------------------------------------------------------------------------------------- Private Sub 合成シートの年月日が指定範囲内のものを判別シートに記入する() Sheets("判別").Select '判別シートを Cells.Clear 'すべてクリアする Sheets("合成").Select '合成シートを Range("A1:AG27").Copy 'コピーして Sheets("判別").Select '判別シートに Range("A1").PasteSpecial Paste:=xlAll 'すべて貼り付ける Range("C2:AG27").ClearContents 'C2〜AG27セルの数式と値をクリアする For 行 = 2 To 26 Step 2 '2行から26行まで2行間隔で For 列 = 3 To 33 'C列からAG列まで 年月日 = Sheets("合成").Cells(行, 列).Value '合成シートから年月日を取り出す If 年月日 >= 開始YMD And 年月日 <= 終了YMD Then '年月日が開始年月日と終了年月日以内なら Range(Cells(行 + 1, 列), Cells(行 + 1, 列)).Value = 1 '判別シートに暦日フラグを記入 色 = Sheets("合成").Cells(行, 列).Interior.ColorIndex '合成シートから色を取り出す If 色 <> -4142 Then '色がなしなら Range(Cells(行, 列), Cells(行, 列)).Value = 1 '判別シートに休日フラグを記入 End If End If Next '最終列まで繰り返す Next '最終行まで繰り返す Range("A1").Select End Sub '========================================================================================= ' V2.0 2000.5.13　　　　　　　　　　　　　　　　　　　　　　ExcelVBAマクロ 500連発 第2弾 '=========================================================================================