昔こんなマクロを作ったのですが、当時はまだVBAを使えるようになったばかりの頃でした。
今見てみると「これはひどい」なコードでした。簡単にバグを起こしそうな感じです。
そういうわけで基本的な機能はそのまま、コードをリファクタリングしてみました。
マクロの内容
サンプルファイルは下記のリンクからダウンロードしてください。ZIP圧縮しています。
こんな感じの年間のカレンダーがあるとします。年が変わると曜日も変わりますので全部書きかえるのはとてもめんどくさいということで自動化するマクロです。元々はトイレ掃除のチェック表用に作ったものでした。
「年間」シートの右上らへんにある「実行」ボタンを押すと、インプットボックスが出てくるので、そこに作成したい西暦を半角4桁の数字で入力します。
そしたらできあがりです。下の方に隠れて見えませんが、1～3月は翌年分です。
ついでに月間カレンダーがシート別にありまして、そっちも変わります。
VBA
Sub カレンダー作成()
Const NENKAN_SHEET_NAME As String = "年間" '年間シート名
Dim thisYear As Variant '入力された西暦
Dim firstWeekday As Integer '4月1日の曜日
Dim monthLength As Integer '1か月の日数
Dim setRow As Long '入力行
Dim setCol As Long '入力列
Dim isLeapYear As Boolean '閏年の判定
Dim monthlySheetArray As Variant '月間カレンダーのシート名を格納する配列
'月間カレンダーのシート名を配列に格納する
monthlySheetArray = Split("4月,5月,6月,7月,8月,9月,10月,11月,12月,1月,2月,3月", ",")
'年度のカレンダーを作成するか入力
thisYear = Application.InputBox("西暦を半角4桁の数字で入力してください。")
'キャンセル時の処理
If thisYear = False Then
Exit Sub
End If
'西暦以外の文字列が入力されたら処理を中止する
If IsDate(thisYear & "/4/1") = False Then
MsgBox "西暦以外の文字列が入力されました。処理を中止します。"
Exit Sub
End If
'次年度分の変数を用意
nextYear = thisYear + 1
'閏年を判定
isLeapYear = False
If nextYear Mod 400 = 0 Then
isLeapYear = True
ElseIf nextYear Mod 100 <> 0 And nextYear Mod 4 = 0 Then
isLeapYear = True
End If
'年間カレンダーの中身をリセットする
For i = 3 To 48 Step 15
Worksheets(NENKAN_SHEET_NAME).Range(Cells(i, 1), Cells(i + 11, 23)).ClearContents
Next
'月間カレンダー各シートの中身をリセットする
For i = 0 To 11
Worksheets(monthlySheetArray(i)).Range("A3:G14").ClearContents
Next i
'年を入力
With Worksheets(NENKAN_SHEET_NAME)
.Range("A1").Value = thisYear & "年"
.Range("A46").Value = nextYear & "年"
'4月1日の曜日を取得、最初に入力する列を決定
firstWeekday = Weekday(thisYear & "/04/01")
setCol = firstWeekday
'年間カレンダーを作成
For i = 1 To 46 Step 15 'm月が書かれている行
For j = 7 To 23 Step 8 '土曜日のある列
setRow = i + 2
'各月の日数を算出
Select Case .Cells(i, j).Value
Case "4月", "6月", "9月", "11月"
monthLength = 30
Case "2月"
If isLeapYear = True Then
monthLength = 29
Else
monthLength = 28
End If
Case Else
monthLength = 31
End Select
'１か月分の日付を入力
For k = 1 To monthLength
.Cells(setRow, setCol).Value = k
If setCol = j Then
setRow = setRow + 2
setCol = j - 6
Else
setCol = setCol + 1
End If
If k = monthLength Then
If j = 23 Then
setCol = setCol - 16
Else
setCol = setCol + 8
End If
End If
Next k
Next j
Next i
End With
'月間カレンダーを作成
setCol = firstWeekday
For i = 0 To 11
With Worksheets(monthlySheetArray(i))
'年を入力
If i >= 9 Then
.Range("F1").Value = nextYear & "年"
Else
.Range("F1").Value = thisYear & "年"
End If
'各月の日数を算出
Select Case i
Case 0, 2, 5, 7
monthLength = 30
Case 10
If isLeapYear = True Then
monthLength = 29
Else
monthLength = 28
End If
Case Else
monthLength = 31
End Select
setRow = 3
'各シートに1ヶ月分の日付を入力
For j = 1 To monthLength
.Cells(setRow, setCol).Value = j
If setCol = 7 Then
setRow = setRow + 2
setCol = 1
Else
setCol = setCol + 1
End If
Next j
End With
Next i
End Sub
コメント