Excel VBAを使用して日付情報をファイル名に追加する方法

Sub GetDate()
    Dim currentDate As Date
    currentDate = Date
    MsgBox "今日の日付は " & Format$(currentDate, "yyyy-mm-dd")
End Sub

Sub GetDateTime()
    Dim currentDateTime As Date
    currentDateTime = Now
    MsgBox "現在の日付と時刻は " & Format$(currentDateTime, "yyyy-mm-dd hh:nn:ss")
End Sub

Sub AddDateToFileName()
    Dim filePath As String
    Dim fileName As String
    Dim newFileName As String
    Dim currentDate As String
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    filePath = "C:\Users\YourUsername\Documents" ' 実在する保存先に変更
    fileName = "example.xlsx"
    currentDate = Format$(Date, "yyyymmdd")

    newFileName = fso.BuildPath(filePath, _
        fso.GetBaseName(fileName) & "_" & currentDate & "." & _
        fso.GetExtensionName(fileName))
    MsgBox "新しいファイル名は: " & newFileName
End Sub

filePath = "C:\Users\YourUsername\Documents"
fileName = "example.xlsx"

currentDate = Format$(Date, "yyyymmdd")

newFileName = fso.BuildPath(filePath, _
    fso.GetBaseName(fileName) & "_" & currentDate & "." & _
    fso.GetExtensionName(fileName))

Option Explicit

Sub SaveWorkbookWithDate()
    On Error GoTo ErrorHandler
    Dim newFileName As String
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Date, "yyyymmdd"), False)
    MsgBox "別名保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox "保存を完了できませんでした: " & Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Sub SaveWorkbookCopyWithDate()
    On Error GoTo ErrorHandler
    Dim newFileName As String
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Date, "yyyymmdd"), True)
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox "コピー保存を完了できませんでした: " & Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Private Function SaveDatedWorkbook(ByVal wb As Workbook, ByVal stamp As String, _
        Optional ByVal copyOnly As Boolean = True, _
        Optional ByVal folderPath As String = "", _
        Optional ByVal baseName As String = "") As String
    Dim fso As Object
    Dim ext As String
    Dim target As String

    If wb Is Nothing Then Err.Raise vbObjectError + 2100, , "対象ブックがありません。"
    If Len(wb.Path) = 0 Then Err.Raise vbObjectError + 2101, , "先に元ブックを保存してください。"
    If Not Application.DisplayAlerts Then
        Err.Raise vbObjectError + 2102, , "警告表示が無効です。呼び出し元の設定を確認してください。"
    End If

    Set fso = CreateObject("Scripting.FileSystemObject")
    Select Case wb.FileFormat
        Case xlOpenXMLWorkbook, xlOpenXMLStrictWorkbook: ext = "xlsx"
        Case xlOpenXMLWorkbookMacroEnabled: ext = "xlsm"
        Case xlExcel12: ext = "xlsb"
        Case xlExcel8: ext = "xls"
        Case Else
            Err.Raise vbObjectError + 2103, , "この例では対応していないファイル形式です。"
    End Select
    If LCase$(fso.GetExtensionName(wb.Name)) <> ext Then
        Err.Raise vbObjectError + 2104, , "元ブックの拡張子と形式が一致していません。"
    End If
    If ext = "xlsx" And wb.HasVBProject Then
        Err.Raise vbObjectError + 2105, , "マクロを含むブックは先に.xlsm等で保存してください。"
    End If
    If Len(folderPath) = 0 Then folderPath = wb.Path
    If Len(baseName) = 0 Then baseName = fso.GetBaseName(wb.Name)
    If Len(stamp) = 0 Then Err.Raise vbObjectError + 2106, , "日付文字列が空です。"
    target = CheckedNewPath(folderPath, baseName & "_" & stamp & "." & ext)

    ' CheckedNewPathの確認と保存は不可分ではない。同じ名前への並行保存は行わない。
    If copyOnly Then
        wb.SaveCopyAs Filename:=target
    Else
        wb.SaveAs Filename:=target, FileFormat:=wb.FileFormat
        If StrComp(wb.FullName, target, vbTextCompare) <> 0 Then
            Err.Raise vbObjectError + 2107, , "別名保存が完了していません。キャンセルや保存イベントを確認してください。"
        End If
    End If
    If Not fso.FileExists(target) Then
        Err.Raise vbObjectError + 2108, , "出力ファイルを確認できません。保存先を確認してください。"
    End If
    SaveDatedWorkbook = target
End Function

Private Function CheckedFolder(ByVal folderPath As String) As String
    Dim fso As Object
    If Len(folderPath) = 0 Or InStr(1, folderPath, "://", vbTextCompare) > 0 Then
        Err.Raise vbObjectError + 2110, , "実在するローカルまたはUNCフォルダーを指定してください。"
    End If
    If Left$(folderPath, 4) = "\\?\" Or Left$(folderPath, 4) = "\\.\" Then
        Err.Raise vbObjectError + 2111, , "特殊なデバイスパスは対象外です。"
    End If
    If Not (folderPath Like "[A-Za-z]:\*") And Left$(folderPath, 2) <> "\\" Then
        Err.Raise vbObjectError + 2112, , "相対パスではなく完全な保存先を指定してください。"
    End If
    If InStr(folderPath, "[") > 0 Or InStr(folderPath, "]") > 0 Then
        Err.Raise vbObjectError + 2113, , "保存先に角括弧を含めないでください。"
    End If
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(folderPath) Then
        Err.Raise vbObjectError + 2114, , "保存先フォルダーが見つかりません。"
    End If
    CheckedFolder = fso.GetFolder(folderPath).Path
End Function

Private Function CheckedNewPath(ByVal folderPath As String, ByVal leafName As String) As String
    Dim fso As Object
    Dim target As String
    CheckFileName leafName
    Set fso = CreateObject("Scripting.FileSystemObject")
    target = fso.BuildPath(CheckedFolder(folderPath), leafName)
    If Len(target) > 218 Then
        Err.Raise vbObjectError + 2120, , "フォルダーを含むパスを218文字以内に短くしてください。"
    End If
    If fso.FileExists(target) Or fso.FolderExists(target) Then
        Err.Raise vbObjectError + 2121, , "同名のファイルまたはフォルダーがあります。上書きしません: " & target
    End If
    CheckedNewPath = target
End Function

Private Sub CheckFileName(ByVal leafName As String)
    Dim i As Long
    Dim ch As String
    Dim deviceName As String
    Dim reserved As Boolean
    If Len(leafName) = 0 Then Err.Raise vbObjectError + 2130, , "ファイル名が空です。"
    If Right$(leafName, 1) = "." Or Right$(leafName, 1) = " " Then
        Err.Raise vbObjectError + 2131, , "末尾がピリオドまたは空白の名前は使えません。"
    End If
    For i = 1 To Len(leafName)
        ch = Mid$(leafName, i, 1)
        If InStr(1, "\/:*?""<>|[]", ch, vbBinaryCompare) > 0 Or _
                (AscW(ch) >= 0 And AscW(ch) < 32) Then
            Err.Raise vbObjectError + 2132, , "使用できない文字がファイル名に含まれています。"
        End If
    Next i
    deviceName = UCase$(Trim$(Split(leafName, ".")(0)))
    Select Case deviceName
        Case "CON", "PRN", "AUX", "NUL": reserved = True
    End Select
    If Len(deviceName) = 4 Then
        If Left$(deviceName, 3) = "COM" Or Left$(deviceName, 3) = "LPT" Then
            reserved = InStr(1, "123456789" & ChrW(185) & ChrW(178) & ChrW(179), _
                Right$(deviceName, 1), vbBinaryCompare) > 0
        End If
    End If
    If reserved Then Err.Raise vbObjectError + 2133, , "Windowsの予約名は使えません。"
End Sub

Set wb = ThisWorkbook

filePath = wb.Path

fileName = fso.GetBaseName(wb.Name)

currentDate = Format$(Date, "yyyymmdd")

target = CheckedNewPath(folderPath, baseName & "_" & stamp & "." & ext)

wb.SaveAs Filename:=target, FileFormat:=wb.FileFormat
' コピーだけを作る場合は、上の行の代わりに次の行を使う
' wb.SaveCopyAs Filename:=target

MsgBox "別名保存しました: " & newFileName

Sub SaveWorkbookWithDateHandled()
    On Error GoTo ErrorHandler
    Dim newFileName As String
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Date, "yyyymmdd"), _
        True, "C:\Users\YourUsername\Documents")
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox "処理を完了できませんでした: " & Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

On Error GoTo ErrorHandler

ErrorHandler:
    MsgBox "処理を完了できませんでした: " & Err.Number & vbCrLf & Err.Description, vbExclamation

Sub SaveWorkbookWithFormattedDate1()
    On Error GoTo ErrorHandler
    Dim newFileName As String
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Date, "yyyy-mm-dd"), True)
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Sub SaveWorkbookWithFormattedDate2()
    On Error GoTo ErrorHandler
    Dim newFileName As String
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Now, "yyyymmdd_hhnnss"), True)
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Sub SaveWorkbookWithFormattedDate3()
    On Error GoTo ErrorHandler
    Dim newFileName As String
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Now, "yyyy_mm_dd_hh_nn_ss"), True)
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Sub SaveSalesDataWithDate()
    Dim sourceWb As Workbook
    Dim exportWb As Workbook
    Dim ws As Worksheet
    Dim fso As Object
    Dim newFileName As String
    Dim oldEvents As Boolean
    Dim stateCaptured As Boolean
    Dim failureNumber As Long
    Dim failureText As String
    Dim cleanupText As String
    Dim saved As Boolean
    On Error GoTo ErrorHandler

    Set sourceWb = ThisWorkbook
    Set ws = sourceWb.Worksheets("SalesData")
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not Application.DisplayAlerts Then
        Err.Raise vbObjectError + 2140, , "警告表示が無効です。呼び出し元の設定を確認してください。"
    End If
    newFileName = CheckedNewPath(sourceWb.Path, _
        "SalesData_" & Format$(Date, "yyyymmdd") & ".xlsx")

    oldEvents = Application.EnableEvents
    stateCaptured = True
    Application.EnableEvents = False
    ws.Copy
    Set exportWb = ActiveWorkbook ' Copy直後の新しいブックだけを保持
    If exportWb Is sourceWb Then Err.Raise vbObjectError + 2141, , "出力ブックを取得できません。"
    If exportWb.HasVBProject Then
        Err.Raise vbObjectError + 2142, , "シートのVBAコードがあるため.xlsxへ変換しません。"
    End If
    If fso.FileExists(newFileName) Or fso.FolderExists(newFileName) Then
        Err.Raise vbObjectError + 2143, , "同名の出力ができたため保存を中止します。"
    End If
    exportWb.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook
    If StrComp(exportWb.FullName, newFileName, vbTextCompare) <> 0 Or _
            Not fso.FileExists(newFileName) Then
        Err.Raise vbObjectError + 2144, , "保存完了を確認できません。"
    End If
    saved = True
    GoTo CleanUp

ErrorHandler:
    failureNumber = Err.Number
    failureText = Err.Description
    Resume CleanUp

CleanUp:
    On Error Resume Next
    If Not exportWb Is Nothing Then
        If Not exportWb Is sourceWb Then exportWb.Close SaveChanges:=False
    End If
    If Err.Number <> 0 Then cleanupText = "出力ブックを閉じられません: " & Err.Description
    Err.Clear
    If stateCaptured Then Application.EnableEvents = oldEvents
    If Err.Number <> 0 Then cleanupText = cleanupText & vbCrLf & "イベント設定を復元できません: " & Err.Description
    On Error GoTo 0
    If failureNumber <> 0 Then
        MsgBox "処理を完了できませんでした: " & failureNumber & vbCrLf & failureText & _
            vbCrLf & "出力ファイルがある場合は内容を確認してください。" & vbCrLf & cleanupText, vbExclamation
    ElseIf Len(cleanupText) > 0 Then
        MsgBox "保存後の後処理を確認してください: " & newFileName & vbCrLf & cleanupText, vbExclamation
    ElseIf saved Then
        MsgBox "売上シートを保存しました: " & newFileName
    End If
End Sub

Set ws = sourceWb.Worksheets("SalesData")

newFileName = CheckedNewPath(sourceWb.Path, _
    "SalesData_" & Format$(Date, "yyyymmdd") & ".xlsx")

currentDate = Format$(Date, "yyyymmdd")

"SalesData_" & Format$(Date, "yyyymmdd") & ".xlsx"

exportWb.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook

MsgBox "売上シートを保存しました: " & newFileName

Sub SaveWorkbookWithDateAndFolderCheck()
    On Error GoTo ErrorHandler
    Dim fso As Object
    Dim parentPath As String
    Dim folderPath As String
    Dim newFileName As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    parentPath = CheckedFolder(ThisWorkbook.Path)
    folderPath = fso.BuildPath(parentPath, "SalesData")
    If fso.FileExists(folderPath) Then
        Err.Raise vbObjectError + 2150, , "SalesDataという同名ファイルがあるためフォルダーを作れません。"
    End If
    If Not fso.FolderExists(folderPath) Then fso.CreateFolder folderPath
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Date, "yyyymmdd"), _
        True, folderPath, "SalesData")
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Private Function RemoveInvalidCharacters(ByVal fileName As String) As String
    Dim invalidChars As String
    Dim i As Long
    invalidChars = "\/:*?""<>|[]"
    For i = 1 To Len(invalidChars)
        fileName = Replace(fileName, Mid$(invalidChars, i, 1), "")
    Next i
    For i = 0 To 31
        fileName = Replace(fileName, Chr$(i), "")
    Next i
    fileName = Trim$(fileName)
    Do While Len(fileName) > 0
        If Right$(fileName, 1) <> "." And Right$(fileName, 1) <> " " Then Exit Do
        fileName = Left$(fileName, Len(fileName) - 1)
    Loop
    If Len(fileName) = 0 Then Err.Raise vbObjectError + 2160, , "有効な名前を入力してください。"
    CheckFileName fileName
    RemoveInvalidCharacters = fileName
End Function

Sub SaveWorkbookWithCleanFileName()
    On Error GoTo ErrorHandler
    Dim fileName As String
    Dim newFileName As String
    fileName = RemoveInvalidCharacters("Sales:Data")
    newFileName = SaveDatedWorkbook(ThisWorkbook, Format$(Date, "yyyymmdd"), _
        True, "", fileName)
    MsgBox "コピーを保存しました: " & newFileName
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub

Sub SaveWorkbookWithRetry()
    On Error GoTo ErrorHandler
    Dim attempt As Long
    Dim stamp As String
    Dim newFileName As String
    Dim errorNumber As Long
    Dim errorText As String
    stamp = Format$(Now, "yyyymmdd_hhnnss")

    For attempt = 1 To 3
        Err.Clear
        On Error Resume Next ' 保存呼び出しだけに限定
        newFileName = SaveDatedWorkbook(ThisWorkbook, stamp, True)
        errorNumber = Err.Number
        errorText = Err.Description
        On Error GoTo ErrorHandler
        If errorNumber = 0 Then
            MsgBox "コピーを保存しました: " & newFileName
            Exit Sub
        End If
        If errorNumber = vbObjectError + 2121 Or attempt = 3 Then
            MsgBox "再試行を停止します: " & errorNumber & vbCrLf & errorText, vbExclamation
            Exit Sub
        End If
        If MsgBox("保存を完了できません: " & errorNumber & vbCrLf & errorText & _
            vbCrLf & "保存先と原因を確認してから再試行しますか？", _
            vbRetryCancel + vbExclamation) <> vbRetry Then Exit Sub
    Next attempt
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub