１か月分のエクセルシートを作成する

昨日パソコンの中身を整理していたところ、昔作った１か月分のエクセルシートを作成するマクロを発見しました。
そういえば、数年前、仕事の必要から作成した記憶があります。

私はもう使うことはありませんが、削除する前にブログにアップして共有します。

１か月分のシート作成
1. 原稿
2. 完成形
１か月分のシートを作るVBA
本日のまとめ

１か月分のシート作成

業務で１か月分のシートを作成する機会は、頻繁に出てくると思います。

業務日報
勤務日誌
売上日報

などです。

今回は、売上日報ということにしています。
毎日の商品別の売上とその合計額です。
10月なら31枚シートが必要になります。

原稿を31回コピーしても作成できますが、それでは非効率です。
また、日付もシートごとに変える必要があります。
これを毎月行うのはちょっと面倒です。

原稿

繰り返しのコピー作業は、マクロが得意とするところです。
一度作成してしまえば、実行には１分もかかりません。
この原稿から１か月分のシート（10月なら31枚）を作ります。

原稿はこちらです。
売上日報.xlsx

完成形

完成形はこちらです。
右側は見切れていますが、31枚のシートが作成されています。
また、D1セルにはシートごとに日付が表示されています。

１か月分のシートを作るVBA

作成したVBAは下のとおりです。
こちらを先ほどのエクセル原稿にマクロとして貼り付ければ動作するはずです。

作成した１か月分のシートが入ったブックは、指定したフォルダに保存されます。
原稿ブックは、変更されることなくそのまま閉じられます。

使い方と、注意点です。

作成する「年」と「月」はプロンプトが表示されます。
保存フォルダは「C:\日誌\」としています。
変更するには、10行目の「savePath = “C:\日誌\”」部分を修正します。
日付はD1セルに入力されます。
ここでの日付は、シートの色分け（土曜日は青、日曜日は赤）にも使用しています。
他のセルに入力する場合は、マクロの62～64行目の「D1」部分を変更します。
D1セルの書式設定は、「yyyy/mm/dd (aaa)」としています。
曜日が不要であれば（aaa）部分を削除するなど、適宜変更できます。
VBAを含め、このブログにより生じた一切の損害について責任を負うものではありません。

Option Explicit

Sub 売上日報作成()

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    ' 保存先フォルダ（必要に応じて変更）
    Dim savePath As String
    savePath = "C:\日誌\"
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath

    ' マクロが入ったブックとテンプレートシート（先頭シート）を参照
    Dim wbMacro As Workbook
    Set wbMacro = ThisWorkbook

    Dim template As Worksheet
    Set template = wbMacro.Worksheets(1)

    ' 入力（西暦・月）
    Dim yearInput As Long
    Dim monthInput As Long
    Dim tmp As String

    tmp = InputBox("作成年（西暦）を入力してください", "作成年入力", Year(Date))
    If Trim(tmp) = "" Then GoTo CleanExit
    If Not IsNumeric(tmp) Then MsgBox "年は数値で入力してください。": GoTo CleanExit
    yearInput = CLng(tmp)

    tmp = InputBox("作成月を入力してください（1～12）", "作成月入力", Month(Date))
    If Trim(tmp) = "" Then GoTo CleanExit
    If Not IsNumeric(tmp) Then MsgBox "月は数値で入力してください。": GoTo CleanExit
    monthInput = CLng(tmp)
    If monthInput < 1 Or monthInput > 12 Then MsgBox "月は1～12で指定してください。": GoTo CleanExit

    If MsgBox("作成年月: " & yearInput & "年" & Format(monthInput, "00") & "月 を作成します。よろしいですか？", _
              vbYesNo + vbQuestion, "作成確認") <> vbYes Then GoTo CleanExit

    ' 当該月の日数を取得
    Dim daysInMonth As Long
    daysInMonth = Day(DateSerial(yearInput, monthInput + 1, 0))

    ' 新規ブック作成（空白シート付き）
    Dim newWB As Workbook
    Set newWB = Workbooks.Add(xlWBATWorksheet)

    Dim dayIdx As Long
    Dim newWS As Worksheet
    Dim sheetName As String

    For dayIdx = 1 To daysInMonth
        ' テンプレートをコピー
        template.Copy After:=newWB.Sheets(newWB.Sheets.Count)
        Set newWS = newWB.Sheets(newWB.Sheets.Count)

        ' シート名（例：0401）
        sheetName = Format(monthInput, "00") & Format(dayIdx, "00")
        On Error Resume Next
        newWS.Name = sheetName
        On Error GoTo ErrHandler

        ' D1 に日付を入力、土日ならタブ色を変更
        newWS.Range("D1").Value = DateSerial(yearInput, monthInput, dayIdx)
        Select Case Weekday(newWS.Range("D1").Value)
            Case vbSunday: newWS.Tab.ColorIndex = 3   '赤
            Case vbSaturday: newWS.Tab.ColorIndex = 41 '青
            Case Else: newWS.Tab.ColorIndex = xlColorIndexNone
        End Select
    Next dayIdx

    ' 最初の空白シートを削除
    Application.DisplayAlerts = False
    If newWB.Sheets(1).Range("A1").Value = "" And newWB.Sheets.Count > daysInMonth Then
        newWB.Sheets(1).Delete
    End If
    Application.DisplayAlerts = True

    ' 先頭シートをアクティブに設定
    newWB.Sheets(1).Activate

    ' ファイル名（西暦）を.xlsxで保存
    Dim fileName As String
    fileName = savePath & "日誌（" & yearInput & "年" & Format(monthInput, "00") & "月）.xlsx"

    newWB.SaveAs fileName:=fileName, FileFormat:=xlOpenXMLWorkbook

    MsgBox "保存しました：" & vbCrLf & fileName, vbInformation
    newWB.Close SaveChanges:=False

CleanExit:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "エラーが発生しました: " & Err.Number & " - " & Err.Description, vbCritical
    Resume CleanExit

End Sub