'========================================================================================= ' 494 スケジュール表 '----------------------------------------------------------------------------------------- '【ヒント】 ' このマクロは、おためし機能の動作用のコードを含んでいます。（概ね下半分） ' ★★★の行またはサブプロシージャーが、タイトル機能に関係するコードです。（概ね上半分） '========================================================================================= ' ◆標準モジュールのコード◆ '----------------------------------------------------------------------------------------- '----------------------------------------------------------------------------------------- Sub おためしマクロ() 作業指示シートを表示する End Sub '----------------------------------------------------------------------------------------- Sub Auto_Close() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close '現在開いているブックを閉じる End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ★ おまかせスケジュール表作成 V1.3 ★ Copyright(c)1998-2000 Yoshioh Nagai '========================================================================================= Option Explicit Dim メッセージ As String Dim タイトル As String Dim 年月 Dim 当月初 As Date Dim 翌月初 As Date Dim 曜(7) As String Dim 曜番 As Integer Dim シート名 As String Dim 削除行数 As Integer Dim 下端 Dim 日付 As Integer Dim 網かけする As Integer '========================================================================================= Sub 作業指示シートを表示する() Application.ScreenUpdating = False '画面を更新しない Sheets("作業指示").Select '初期画面選択 Range("A1:AD21").Select ActiveWindow.Zoom = True 'ズームする Range("C11").Select End Sub '========================================================================================= Sub スケジュール表作成() On Error GoTo エラー処理 '予期せぬエラーへの対策 Sheets("作業指示").Activate '初期画面選択 Application.ScreenUpdating = False '画面を更新しない Range("C11").Select 曜(1) = "日": 曜(2) = "月": 曜(3) = "火": 曜(4) = "水": 曜(5) = "木": 曜(6) = "金": 曜(7) = "土" メッセージ = "00/4か 2000/4 または H12/4のように入れてください。 （Windows版は1900年1月1日を基準とするExcelの仕様で曜日が計算されます)" タイトル = "年月は？" 年月 = Application.InputBox(prompt:=メッセージ, Title:=タイトル) 'インプットボックスで入力 If 年月 = False Then 'キャンセルボタンが押された Exit Sub End If ' その月の日数と月初の曜日を調べて表示する シートを準備する 日付と曜日と月を記入しページレイアウトする ActiveSheet.PrintPreview '印刷プレビュー Sheets("作業指示").Select On Error GoTo 0 'エラー対策を解除 Exit Sub '正常終了 '----------------------------------------------------------------------------------------- エラー処理: 'エラーが発生した時の入り口 タイトル = "予期せぬエラーが発生しました ... " & Str(Err) & ": " & Error(Err) メッセージ = " [対処例] 正しい年月を入れる、他" & Chr(13) & Chr(13) & _ "作業を中止します。原因を取り除いてから、やり直してください。" MsgBox メッセージ, vbCritical, タイトル Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない Workbooks.Close 'ブックをすべて閉じる End Sub '----------------------------------------------------------------------------------------- Private Sub その月の日数と月初の曜日を調べて表示する() 当月初 = DateValue(年月 & "/1") 'その月の月初 If Month(当月初) < 12 Then '当月初が11月以前なら 翌月初 = DateValue(Year(当月初) & "/" & Month(当月初) + 1 & "/1") '翌月初は当年 Else 翌月初 = DateValue(Year(年月) + 1 & "/1/1") '翌月初は翌年 End If Sheets("原紙").Select ActiveSheet.Unprotect 'シート保護解除 Range("H1") = 年月 '入力された年月 Range("H2") = 当月初 'その月の月初 Range("H3") = 翌月初 'その翌月初 Range("H5") = 曜(Weekday(年月 & "/1")) '曜日から始まります Range("H6") = Weekday(年月 & "/1") 'その曜日の順番 ActiveSheet.Protect DrawingObjects:=True, _ Contents:=True, Scenarios:=True 'シート保護 End Sub '----------------------------------------------------------------------------------------- Private Sub シートを準備する() Sheets("前月").Select Application.DisplayAlerts = False '確認メッセージを出さない ActiveWindow.SelectedSheets.Delete 'シート削除 Sheets("当月").Name = "前月" 'シート名を「前月」に変更 ' Sheets("原紙").Copy Before:=Sheets(2) 'シートのコピー シート名 = ActiveSheet.Name 'シート名を覚える Sheets(シート名).Name = "当月" 'シート名を「当月」に変更 ActiveSheet.Unprotect 'シート保護解除 Columns("G:I").Delete Shift:=xlToLeft 'パラメータ列を削除 ' If Sheets("原紙").Cells(4, 8) < 31 Then 'その月の日数 For 削除行数 = Sheets("原紙").Cells(4, 8) + 1 To 31 Rows("2:2").Delete Shift:=xlUp '１行削除する Next End If End Sub '----------------------------------------------------------------------------------------- Private Sub 日付と曜日と月を記入しページレイアウトする() 下端 = Range("A1").End(xlDown).Row 'セルA1の列の下端を選択 Range("A2:B32").ClearContents '日付をクリア Range("A2:D32").Interior.ColorIndex = xlNone '網かけをクリア 曜番 = Sheets("原紙").Cells(6, 8) '月初の曜日の番号 For 日付 = 1 To 下端 - 1 Cells(日付 + 1, 1).Value = 日付 '日付を記入 Cells(日付 + 1, 2).Value = 曜(曜番) '曜日を記入 指示があれば曜日で網かけする If 曜番 = 7 Then '土曜日なら 曜番 = 1 '曜番を日曜日にもどす Else 曜番 = 曜番 + 1 End If 指示があれば日付で網かけする Next ActiveSheet.PageSetup.LeftHeader = "&""ＭＳ Ｐゴシック,太字""&14 " & 年月 '左側ヘッダ Range("C2").Select End Sub '----------------------------------------------------------------------------------------- Private Sub 指示があれば曜日で網かけする() If Sheets("作業指示").Cells(11, 3 - 1 + 曜番) = 1 Then '網かけ指示 Range(Cells(日付 + 1, 1), Cells(日付 + 1, 4)).Select With Selection.Interior '網かけ .ColorIndex = 40 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With End If End Sub '----------------------------------------------------------------------------------------- Private Sub 指示があれば日付で網かけする() 網かけする = 0 If 日付 < 16 Then '1〜15日の場合 If Sheets("作業指示").Cells(11, 13 - 1 + 日付) = 1 Then '網かけ指示 網かけする = 1 End If Else '16〜31日の場合 If Sheets("作業指示").Cells(14, 13 - 16 + 日付) = 1 Then 網かけする = 1 End If End If If 網かけする = 1 Then Range(Cells(日付 + 1, 1), Cells(日付 + 1, 4)).Select With Selection.Interior '網かけ .ColorIndex = 40 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With End If End Sub '========================================================================================= Sub 終了処理() If ActiveWorkbook.Saved = False Then 'ブックの内容が変更されているなら Worksheets("Title").Activate ActiveWorkbook.Save 'ブックを上書き保存する End If Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close 'このブックを閉じる End Sub '========================================================================================= ' V1.3 2000.5.5　　　　　　　　　　　　　　　　　　　　　　　ExcelVBAマクロ 500連発 第2弾 '=========================================================================================