月の予定表をシート1枚に作成して、1年分(12シート)を1つのブックにするように作成しています。
1枚目のシートをコピーして、シート名を月に変更して・・・という作業が面倒なので、VBAでやるようになりました。
< スポンサーリンク >
ひと月分のシートを12ヶ月分作る方法
テンプレート用のシートを1枚作ります。
C1に年、D1に月を数値で入れるようにし、表示形式をユーザー定義で「年」「月」がつくようにしておきます。
A4にC1とD1から年と月を取得し、その月の1日の日付が表示されるようにします。
A5に =A4+1 と入力し、上の行に1日足した日付が表示されるようにします。
A4をA5~A34までコピーします。
29日~31日は無い月もあるので、D1の月とそのセルの月が同じではない場合は何も表示されないように、A32に下記のように入力します。
=IFERROR(IF(MONTH(A31+1)=$D$1,A31+1,””),””)
A32をA33~A34までコピーします。
B4はA4を参照し、曜日が表示されるようにします。
B4をB5~B34までコピーします。
C1に年、D1に月を入力するとA列、B列に日と曜日が入り予定表になります。
標準モジュールに下のように記述する。
Sub newSchedule()
On Error Resume Next
‘ 変数の宣言
Dim acWB As Workbook ‘ このブック用
Dim newWB As Workbook ‘ 新しいブック用
Dim acWS As Worksheet ‘ このブックのSheet1用
Dim newWS As Worksheet ‘ 新しいブックの新しいシート用
Dim cntWS As Integer ‘ 新しいブックのシート数用
Dim i As Byte ‘ 繰り返し用
Dim y As Integer ‘ 年用
Dim m As Byte ‘ 月用
Dim FileNameY As Integer ‘ ファイル名の年用
Dim scheDate As Date ‘ 日付用
Dim dirName As String ‘ フォルダ名用
‘ このブックを変数にセット
Set acWB = ThisWorkbook
‘ Sheet1を変数にセット
Set acWS = acWB.Sheets(“Sheet1”)
‘ Sheet1を新しいブックにコピー
acWS.Copy
‘ 新しいブックを変数にセット
Set newWB = ActiveWorkbook
‘ コピーしたシートを変数にセット
Set newWS = newWB.ActiveSheet
‘ Sheet1の年と月でその月の1日の日付を取得
scheDate = DateSerial(acWS.Range(“C1”).Value, acWS.Range(“D1”).Value, 1)
‘ 12回繰り返す
For i = 1 To 12
If i > 1 Then
‘ 新しいブックのシート数を数える
cntWS = newWB.Sheets.Count
‘ 元のブックのSheet1を新しいブックの最後尾にコピーする
acWS.Copy After:=newWB.Sheets(cntWS)
‘ コピーしたシートを変数にセット
Set newWS = newWB.ActiveSheet
End If
‘ 日付から年と月を取得
y = Year(scheDate)
m = Month(scheDate)
‘ ファイル名用の年を変数に入れる
If FileNameY = 0 Then
FileNameY = y
End If
‘ コピーしたシートのC1に年、D1に月を入力
newWS.Range(“C1”).Value = y
newWS.Range(“D1”).Value = m
‘ コピーしたシート名を「年月」に変える
newWS.Name = y & “年” & m & “月”
‘ 日付を1ヶ月後にする
scheDate = DateSerial(y, m + 1, 1)
Next
‘ 新しいブックの最初のシートをアクティブにする
newWB.Sheets(1).Activate
‘ このブックのフォルダを取得
dirName = acWB.Path
‘ 新しいブックを名前を付けて保存
newWB.SaveAs dirName & “\” & FileNameY & “年予定表.xlsx”
End Sub
On Error Resume Next
‘ 変数の宣言
Dim acWB As Workbook ‘ このブック用
Dim newWB As Workbook ‘ 新しいブック用
Dim acWS As Worksheet ‘ このブックのSheet1用
Dim newWS As Worksheet ‘ 新しいブックの新しいシート用
Dim cntWS As Integer ‘ 新しいブックのシート数用
Dim i As Byte ‘ 繰り返し用
Dim y As Integer ‘ 年用
Dim m As Byte ‘ 月用
Dim FileNameY As Integer ‘ ファイル名の年用
Dim scheDate As Date ‘ 日付用
Dim dirName As String ‘ フォルダ名用
‘ このブックを変数にセット
Set acWB = ThisWorkbook
‘ Sheet1を変数にセット
Set acWS = acWB.Sheets(“Sheet1”)
‘ Sheet1を新しいブックにコピー
acWS.Copy
‘ 新しいブックを変数にセット
Set newWB = ActiveWorkbook
‘ コピーしたシートを変数にセット
Set newWS = newWB.ActiveSheet
‘ Sheet1の年と月でその月の1日の日付を取得
scheDate = DateSerial(acWS.Range(“C1”).Value, acWS.Range(“D1”).Value, 1)
‘ 12回繰り返す
For i = 1 To 12
If i > 1 Then
‘ 新しいブックのシート数を数える
cntWS = newWB.Sheets.Count
‘ 元のブックのSheet1を新しいブックの最後尾にコピーする
acWS.Copy After:=newWB.Sheets(cntWS)
‘ コピーしたシートを変数にセット
Set newWS = newWB.ActiveSheet
End If
‘ 日付から年と月を取得
y = Year(scheDate)
m = Month(scheDate)
‘ ファイル名用の年を変数に入れる
If FileNameY = 0 Then
FileNameY = y
End If
‘ コピーしたシートのC1に年、D1に月を入力
newWS.Range(“C1”).Value = y
newWS.Range(“D1”).Value = m
‘ コピーしたシート名を「年月」に変える
newWS.Name = y & “年” & m & “月”
‘ 日付を1ヶ月後にする
scheDate = DateSerial(y, m + 1, 1)
Next
‘ 新しいブックの最初のシートをアクティブにする
newWB.Sheets(1).Activate
‘ このブックのフォルダを取得
dirName = acWB.Path
‘ 新しいブックを名前を付けて保存
newWB.SaveAs dirName & “\” & FileNameY & “年予定表.xlsx”
End Sub
マクロ有効ブックで保存します。
C1とD1に年と月を入力しVBAを実行すると、12ヶ月分の予定表シートがある新しいファイルが出来ます。
12ヶ月分のシートは単純に12回繰り返してシートを増やしているので、4月から始まる年度でも大丈夫です。
こんな記事も書いています