月の予定表の1シートをVBAで12ヶ月分のシートにする

月の予定表をシート1枚に作成して、1年分(12シート)を1つのブックにするように作成しています。

1枚目のシートをコピーして、シート名を月に変更して・・・という作業が面倒なので、VBAでやるようになりました。

 

テンプレート用のシートを1枚作ります。

 

C1に年、D1に月を数値で入れるようにし、表示形式をユーザー定義で「年」「月」がつくようにしておきます。

schedule
schedule

 

A4にC1とD1から年と月を取得し、その月の1日の日付が表示されるようにします。

schedule

 

A5に =A4+1 と入力し、上の行に1日足した日付が表示されるようにします。

schedule

 

A4をA5~A34までコピーします。

schedule

 

29日~31日は無い月もあるので、D1の月とそのセルの月が同じではない場合は何も表示されないように、A32に下記のように入力します。
=IFERROR(IF(MONTH(A31+1)=$D$1,A31+1,""),"")

schedule

 

A32をA33~A34までコピーします。

schedule

 

B4はA4を参照し、曜日が表示されるようにします。

schedule

 

B4をB5~B34までコピーします。

schedule

 

C1に年、D1に月を入力するとA列、B列に日と曜日が入り予定表になります。

schedule

 

標準モジュールに下のように記述する。

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

 

マクロ有効ブックで保存します。

schedule

 

C1とD1に年と月を入力しVBAを実行すると、12ヶ月分の予定表シートがある新しいファイルが出来ます。

12ヶ月分のシートは単純に12回繰り返してシートを増やしているので、4月から始まる年度でも大丈夫です。

 

< スポンサードリンク >



サブコンテンツ

このページの先頭へ