日報作成等がたぶん気持ち楽になるマクロ（Excel、Wordを名前の日付だけ変更して、その月分だけ複製）

以下画像のように、あるExcel・Wordファイルの名前を日付だけ変更して複製するマクロです。

日付変更複製したいExcel・Wordに対し、開発タブ=>VBを開く=>以下のマクロをコピペ＆=>マクロ有効ブック（.xlsm）で保存＝>以下のマクロを実行することでイメージのように日付変更だけされたファイルが複製されます。

マクロ実行前・実行後イメージ

これがこうなる

※中身は同じです

---

※注意　複製されるファイル名の日付以前の部分はいずれも下記の「テスト」にあたる部分であり、マクロを実行する元のファイル名ではありません。

 Filename:=保存先 & "\テスト" & 何月 & "月" & 何日 & "日" & ".xlsm"

①Excel、日付の数字が半角バージョン

こちらは開発タブ＝＞VBを開いてそのままコピペすると使えます

これをVBにコピペ

Sub 数字半角日付変更複製()
'    変数（保存先）を宣言
    Dim 保存先 As String
    
'    マクロが書かれているブックのパス名を変数（保存先）に格納
    保存先 = ThisWorkbook.Path

' 変数（何月）を宣言
    Dim 何月 As String
    ' 何月かを変える場合はここの数字を1～12で適宜差し替えてください
    何月 = 9
    
    ' 何月かに応じて最終日を決定
    Dim 最終日 As Integer
    Select Case 何月
        Case "4", "6", "9", "11"
            最終日 = 30
        Case "2"
            ' 閏年チェックを行わず、2月の最大日数は28と仮定
            最終日 = 28
        Case Else
            最終日 = 31
    End Select
    
    ' ファイルの複製と保存
    
'    変数（何日）を宣言
    Dim 何日 As Integer
    
'    何日かとばしで作成するときは To の後の数字の後に「半角スペース Step とばす分の数字」を付け足してください

'　　適宜、"月"、"日"は半角などを入れるなどして位置は調整してください。

'    適宜、"\テスト"を "\保存したいファイル名" に変更してください

    For 何日 = 1 To 最終日
        ThisWorkbook.SaveCopyAs _
            Filename:=保存先 & "\テスト" & 何月 & "月" & 何日 & "日" & ".xlsm"
    Next 何日
    
End Sub

②Excel、日付の数字が全角バージョン

こちらは使用する際、Sheet1にあたるシートのAA列に以下のように文字列で１，２、・・・、３１と記述してから使用してください。（以下マクロの後半のRangeの引数の「AA」に対応しています。複製したいものに合わせて適宜列を表す英数字差し替えてください。）

こんな感じで入力してください＆マクロ実行結果

なお、マクロを実行するとこんな感じ

※複製したファイルについては、AAに記述した文字列の数字は消えるようになっています

これをVBにコピペ

Sub 数字全角日付変更複製()
    ' 変数（保存先）を宣言
    Dim 保存先 As String
    ' マクロが書かれているブックのパス名を変数（保存先）に格納
    保存先 = ThisWorkbook.Path
    
    ' 変数（何月）を宣言
    Dim 何月 As String
    ' 何月かを変える場合はここの数字を1～12で適宜差し替えてください
    何月 = "９"
    
    ' 変数 (何日)を宣言
    Dim 何日 As String
    
    ' 変数（num）を宣言
    Dim num As Integer
    
    ' 何月かに応じて最終日を決定
    Dim 最終日 As Integer
    Select Case 何月
        Case "４", "６", "９", "１１"
            最終日 = 30
        Case "２"
            ' 閏年チェックを行わず、2月の最大日数は28と仮定
            最終日 = 28
        Case Else
            最終日 = 31
    End Select
    
    ' ファイルの複製と保存
    For num = 1 To 最終日
        ' 日付の取得（セルの値が使用されている場合）
        何日 = ThisWorkbook.Worksheets(1).Range("AA" & num).Value
        
        ' 保存先のファイルパスとファイル名を生成

        '「テスト」の部分を保存したいファイル名に適宜変更してください

        Dim 保存ファイルパス As String
        保存ファイルパス = 保存先 & "\テスト" & 何月 & "月" & 何日 & "日.xlsm"
        
        ' 現在のブックをコピーして保存
        ThisWorkbook.SaveCopyAs Filename:=保存ファイルパス
        
        ' 保存したファイルを開く（エラーチェック付き）
        On Error Resume Next
        Dim 新しいブック As Workbook
        Set 新しいブック = Workbooks.Open(保存ファイルパス)
        If Err.Number <> 0 Then
            MsgBox "ファイルを開く際にエラーが発生しました: " & 保存ファイルパス, vbCritical
            Err.Clear
        Else
            ' AA列の値をクリア
            新しいブック.Worksheets(1).Range("AA1:AA31").ClearContents
            ' ファイルを保存して閉じる
            新しいブック.Close SaveChanges:=True
        End If
        On Error GoTo 0
    Next num
End Sub

③Word、日付の数字が半角バージョン

こちらも開発タブ＝＞VBを開いてそのままコピペすると使えます

これをVBにコピペ

Sub 数字半角日付変更複製()
'    変数（保存先）を宣言
    Dim 保存先 As String
    
'    マクロが書かれているブックのパス名を変数（保存先）に格納
    保存先 = ThisDocument.Path

' 変数（何月）を宣言
    Dim 何月 As String
    ' 何月かを変える場合はここの数字を1～12で適宜差し替えてください
    何月 = 9
    
    ' 何月かに応じて最終日を決定
    Dim 最終日 As Integer
    Select Case 何月
        Case "4", "6", "9", "11"
            最終日 = 30
        Case "2"
            ' 閏年チェックを行わず、2月の最大日数は28と仮定
            最終日 = 28
        Case Else
            最終日 = 31
    End Select
    
    ' ファイルの複製と保存
    
'    変数（何日）を宣言
    Dim 何日 As Integer
    
'    何日かとばしで作成するときは To の後の数字の後に「半角スペース Step とばす分の数字」を付け足してください

'　　適宜、"月"、"日"は半角などを入れるなどして位置は調整してください。

'    適宜、"\テスト"を "\保存したいファイル名" に変更してください

    For 何日 = 1 To 最終日
        ThisDocument.SaveAs2 _
            FileName:=保存先 & "\テスト " & 何月 & "月" & 何日 & "日" & ".docm"
    Next 何日
    
End Sub

④Word、日付の数字が全角バージョン

こちらも開発タブ＝＞VBを開いてそのままコピペすると使えます

※なお、なぜかこいつだけ複製するファイルの拡張子が「.docx（マクロなし）」にしてもエラーになりません。他はマクロなしの拡張子にすると複製ファイルは壊れて開けません。なぜ(?_?)まあ動くならいいです（´д｀）

これをVBにコピペ

Sub 数字全角日付変更複製()
    ' 変数（保存先）を宣言
    Dim 保存先 As String
    ' マクロが書かれているドキュメントのパス名を変数（保存先）に格納
    保存先 = ThisDocument.Path
    
    ' 変数（何月）を宣言
    Dim 何月 As String
    ' 何月かを変える場合はここの数字を1～12で適宜差し替えてください
    何月 = "９"
    
    ' 変数（何日）を宣言
    Dim 何日 As String
    
    ' 変数（num）を宣言
    Dim num As Integer
    
    ' 全角数字の日付リストを取得
    Dim 全角日付 As Variant
    全角日付 = Split("１、２、３、４、５、６、７、８、９、１０、１１、１２、１３、１４、１５、１６、１７、１８、１９、２０、２１、２２、２３、２４、２５、２６、２７、２８、２９、３０、３１", "、")
    
    ' 何月かに応じて最終日を決定
    Dim 最終日 As Integer
    Select Case 何月
        Case "４", "６", "９", "１１"
            最終日 = 30
        Case "２"
            ' 閏年チェックを行わず、2月の最大日数は28と仮定
            最終日 = 28
        Case Else
            最終日 = 31
    End Select
    
    ' 取得した日付の数と最終日を比較
    If UBound(全角日付) + 1 < 最終日 Then
        MsgBox "ドキュメント内の日付の数が足りません。"
        Exit Sub
    End If
    
    ' ファイルの複製と保存
    For num = 1 To 最終日
        ' 日付の取得（文書内の全角数字を利用）
        何日 = Trim(全角日付(num - 1)) ' 配列は0ベースなので-1する
        
        ' 保存先のファイルパスとファイル名を生成
        ' ここの拡張子を.docmにしなくてもなぜかいける
        Dim 保存ファイルパス As String
        保存ファイルパス = 保存先 & "\テスト" & 何月 & "月" & 何日 & "日.docx"
        
        ' 新しいドキュメントを作成し、内容をコピー
        Dim 新しいドキュメント As Document
        Set 新しいドキュメント = Documents.Add(Template:=ThisDocument.FullName, NewTemplate:=False)
        
        ' 新しいドキュメントを保存
        新しいドキュメント.SaveAs2 FileName:=保存ファイルパス
        
        ' ファイルを保存して閉じる
        新しいドキュメント.Close SaveChanges:=True
    Next num
End Sub

上２つのマクロ実行後のイメージ

主な学習参考資料

①今すぐ使えるかんたん　Excel マクロ＆VBA　技術評論社 門脇香奈子　著

Amazonリンク

https://www.amazon.co.jp/%E4%BB%8A%E3%81%99%E3%81%90%E4%BD%BF%E3%81%88%E3%82%8B%E3%81%8B%E3%82%93%E3%81%9F%E3%82%93-Excel%E3%83%9E%E3%82%AF%E3%83%AD-Office-Microsoft-365%E5%AF%BE%E5%BF%9C%E7%89%88/dp/4297129701/ref=sr_1_1?__mk_ja_JP=%E3%82%AB%E3%82%BF%E3%82%AB%E3%83%8A&crid=37ZL2XQLH7MCJ&dib=eyJ2IjoiMSJ9.veEBhinCRE4Wq14UVCTa99_zIXPLU4u5y8S-28Nwitq1KqAJFmM6ZqZInO3OfKXXGghhQ4KE_yyT3AHYpl5ymh3IT07jHHrac5Z5daMPeccBAJuADDqSefEjSVyf9zv1m-T3N36uWam6grcTAEAWLnkAYtrXxp0vtfNGyne3TR3hIk2AbrcTEXmrxYM5o-f1MR5yRN0JHH_RAs_uotyocQvupOfYQs4EXAOksiL4pZ2LnbNLuOL7l3bgvnV8ZYdkz8_DgY7G68CUYHHZzOzJfw939Vyme_NqPPsKaTQvSNE.fyWS7m_b4yuuDxIKv8qng5c4FSam9d4eQzSMH353v3Y&dib_tag=se&keywords=%E4%BB%8A%E3%81%99%E3%81%90%E4%BD%BF%E3%81%88%E3%82%8B%E3%81%8B%E3%82%93%E3%81%9F%E3%82%93+excel+%E3%83%9E%E3%82%AF%E3%83%AD%26vba+%E6%8A%80%E8%A1%93%E8%A9%95%E8%AB%96%E7%A4%BE+%E9%96%80%E8%84%87%E9%A6%99%E5%A5%88%E5%AD%90+%E8%91%97&qid=1724942343&sprefix=%E4%BB%8A%E3%81%99%E3%81%90%E4%BD%BF%E3%81%88%E3%82%8B%E3%81%8B%E3%82%93%E3%81%9F%E3%82%93+excel+%E3%83%9E%E3%82%AF%E3%83%AD+vba+%E6%8A%80%E8%A1%93%E8%A9%95%E8%AB%96%E7%A4%BE+%E9%96%80%E8%84%87%E9%A6%99%E5%A5%88%E5%AD%90+%E8%91%97%2Caps%2C199&sr=8-1

②エクセルの神髄

③Chat-GPT3.5