VBAでCalendar_2

今回は、[Sample]のようなカレンダーを作成します。

Sample

それでは、今回も準備から進めます。
VBAでCalendar_1で作った「暦.xlsm」を開いてシート「操作卓」とシート「mm月」を作ってください。
可能であれば、シートタブの色を変えおくと便利です。
なお「mm月」については、セルの結合に注意してください。また、2行目B列と3行目Y列については、セルの書式設定でそれぞれ年と月が出るように設定してください。（ユーザー定義で単位を設定）

操作卓

mm月

例として、水曜日始まりの2週間をスパンとするものを作ってみましょう。そして、一日分を2列にすることで例えば左の列に午前の予定、右に午後の予定を記入（入力）できるものとします。
使い方は、「操作卓」5行目F列に西暦年を入れて実行キーをクリックするとその1年分（12シート）を作成します。
作成終了後に、1年分のシートをBookに書き出す機能も入れておきましょう。準備ができたら、コーディングに着手します。
Procedureは3つあります。まずメインのSub MR()を作りましょう。
ここでは、カレンダーについての基本的な設定を行って、Sub CDR()に必要項目を渡して実際のカレンダーを作成します。そして、1年分終了したらSub Exp_B()でBookに書き出すようにしましょう。

Sub MR()で必要なことは、主に12月分の日数を把握することです。そのために便利な配列を使います。配列名をMMとしてDim MM(12)で宣言します。（12）は「№0～№12の箱」の意味なので、実際は13個の箱が用意されますが、わかりやすいように1月～12月を対応付けすることにして、№0の箱は無視しましょう。
Dimの後に、MM(1)=31:MM(3)=31:MM(4)=30:・・・MM(12)=31として2月を除く月数をセットしてください。
2月は、VBAでCalendar_1のaaaで作ったように
YY = Cells(5, "F"): MM(2) = Day(DateSerial(YY, 3, 1) - 1)とすると必要とする年2月の日数がセットされます。
次に、1月～12月を繰り返すようにしますが、今回はここに一工夫してあります。
ひと月分を1シートに書き出そうとしているので、この状態で普通に1月から追加すると2枚目の後に1月、3枚目の後に2月というように、常に最後のシートを意識する必要があります。そこで、12月から11月10月と作っていくと、常に2枚目の後に追加するとで、完成後は左から1月～12月の順に並びます。
最後にBookを作成するかMsgboxで確認して「はい」ボタンがクリックされたら、Book作成Procedureを実行します。
完成サンプルは

Sub MR()  'MainRoutine

Dim MM(12)
    MM(1) = 31: MM(3) = 31: MM(4) = 30: MM(5) = 31: MM(6) = 30: MM(7) = 31
    MM(8) = 31: MM(9) = 30: MM(10) = 31: MM(11) = 30: MM(12) = 31

    YY = Cells(5, "F"): MM(2) = Day(DateSerial(YY, 3, 1) - 1)

    If Sheets.Count > 2 Then

       RC = MsgBox("　　　既存のシートを削除して、新しい" & Chr(13) _
                 & "　　　カレンダーを作成します。" & Chr(13) & Chr(13) _
                 & "　　　処理を継続しますか？" & Chr(13) _
                 & "　　　[は   い]：削除して作成する" & Chr(13) _
                 & "　　　[いいえ]：処理を中断する" _
                 , 4 + 32, "Calendar作成　　　　　　 　　　　　nJun")

       If RC <> 6 Then Exit Sub

       Application.DisplayAlerts = False
       For n = 3 To Sheets.Count
         Sheets(3).Delete
       Next n
       Application.DisplayAlerts = True

    End If

    For n = 12 To 1 Step -1  '12月から逆順に作成する

      CRD YY, n, MM(n) 'Calendar作成 YY:西暦年 n:月 MM(n):月の日数

    Next n

    RC = MsgBox("　　　指定された西暦のカレンダーを作成しました。" & Chr(13) _
              & "　　　Bookとして出力しますか？" & Chr(13) & Chr(13) _
              & "　　　[は   い]：Bookを作成してシートを削除する" & Chr(13) _
              & "　　　[いいえ]：このままなにもしない" _
              , 4 + 32, "Calendar作成　　　　　　 　　　　　　　　　　nJun")
    If RC = 6 Then

       Exp_B  'Book作成
       Sheets(1).Select

    End If

End Sub

です。
なお、既存のシートがあった場合に、削除する手順等を追加しています。

Sub CDR()で実際のカレンダーを作成します。
カレンダーを作るには、年・月・月の日数が必要なので、この情報を受取るためにSub CDR(YY,Mo,LD)として、変数YYに西暦年、Moに作成月、LDにその月の日数を受取ります。よく見ると、Sub MR()で渡すときの変数名と異なっていますが、変数名には関係なく、記述の順番に対応していますので、ご注意ください。
ここで必要な処理は、まず２枚目のシートの後ろに、シート「mm月」をCopyしてその名前をMo月に変えます。
そして、新規作成シートを区別するためにシートタブの色を無色にします。その後、年と月を所定のセルにセットします。
シートの用意ができたらひと月分の日にちをセットします。これは、1～最終日を7列の表に繰り返し出力する処理なので、以前宛名シール（箸休め_6）で作った算式をそのまま活用できます。しかも、最初の書き出し位置（i）の値をうまく使うことで、今回の処理にピッタリです。
書出し位置は、１日の曜日によって決まるので、１日の曜日を調べます。
曜日は、前回のVBAでCalendar_1でWeekday(YMD, a)を使うことが分かっているので簡単です。
YMDは文字列の日付にするために「年/月/日」を編集して代入します。
aの値については、今回水曜日から始めるために4にすると水曜日が1になるので、調整値iはそれから1を引いて。
YMD = YY & "/" & Mo & "/1"
i = Weekday(YMD, 4) - 1 　となります。
あとは、表に合わせてR・ J・ S・ga・ ra をセットするだけです。
完成サンプルは

Sub CRD(YY, Mo, LD) 'Calendar作成 YY:西暦年 Mo:月 LD:月の日数

    Sheets("mm月").Copy after:=Sheets(2)
    Sheets(3).Name = Replace("mm月", "mm", Mo)
    Sheets(3).Tab.ColorIndex = xlColorIndexNone  'シートタブの色を無色に
    Cells(2, "B") = YY: Cells(3, "Y") = Mo

    YMD = YY & "/" & Mo & "/1"  'YMD=YY年Mo月1日
    i = Weekday(YMD, 4) - 1     'YMDが水曜日のとき1を返す(木曜日のとき2,金曜日のとき3・・・)

    R = 14: J = 7: S = 2: ga = 7: ra = 2
    For n = 1 To LD

      行 = Fix((n + i - 1) / R) * J + ga
      列 = (n + i - Fix((n + i - 1) / R) * R - 1) * S + ra

      Cells(行, 列) = n

    Next n

End Sub

です。なお、R・J・ｓ・・・の詳細については箸休め_6をご参照ください。

Bookを作るProcedureはVBAでBingo5_6で作ったExp_Bをほぼそのまま活用できると思います。
違う部分は、
Book名を西暦年にする。
Bookにするシートは、３枚目から。
Book作成後1月～12月のシートは無条件に削除する。
などです。
完成サンプルは

Sub Exp_B()  'B5.xlsmより

    YY = Sheets("操作卓").Cells(5, "F")
    Bn = Replace("xxxx.xlsx", "xxxx", YY)  'Book名

    Sc = Sheets.Count
    ReDim bbb(Sc - 3)

    For i = 3 To Sc
      bbb(i - 3) = Sheets(i).Name
    Next i

    Sheets(bbb).Copy
    DR = ThisWorkbook.Path

    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=DR & "\" & Bn, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Sheetを新規Bookとして書き出す
    ActiveWindow.Close

    For n = 3 To Sheets.Count: Sheets(3).Delete: Next n
    Application.DisplayAlerts = True

End Sub

となります。
今年のカレンダーを作成して、各月の曜日や２月の日数等正しいことが確認できたら、任意の年を作ってみてください。
ちなみに、1900年や1800年における2月の日数にも興味がありますね。

今回も最後までご覧いただき、ありがとうございました。