トップ　>　汎用コード　>　ファイル名に日付を追加

'***************************************************************
'* 選択したファイルの名前に日付を追加する
'*--------------------------------------------------------------
'* 概要     | ファイル選択ダイアログボックスで選択したファイルの
'*          | 名前に日付を追加する（複数ファイル選択可）
'*          | 参考：https://excel.syogyoumujou.com/vba/add_date.html
'* 引数     | なし
'* 戻り値   | なし
'* 作成日   | 2021.12.21
'*--------------------------------------------------------------
'* 更新日   | 2026.04.04
'***************************************************************
Public Sub addDateToFileNames()
On Error GoTo LBL_ERROR

    '------------------------------
    ' ファイル選択
    '------------------------------
    Dim varFilePaths As Variant
    varFilePaths = Application.GetOpenFilename("全てのファイル,*.*", , "ファイル選択", , True)
    If VarType(varFilePaths) = vbBoolean Then Exit Sub

    '------------------------------
    ' 日付文字列の生成
    '------------------------------
    Dim strDate As String
    strDate = "_" & Format$(Date, "yyyymmdd")

    '------------------------------
    ' ファイル名に日付を追加
    '------------------------------
    Dim varFilePath     As Variant
    Dim strNewFilePath  As String
    Dim lngDotPos       As Long
    Dim lngRenameCount  As Long
    Dim lngErrorCount   As Long

On Error Resume Next
    For Each varFilePath In varFilePaths
        lngDotPos = InStrRev(varFilePath, ".")
        If 0 < lngDotPos Then
            ' 新しいファイルパスを生成
            strNewFilePath = Left$(varFilePath, lngDotPos - 1) & strDate & Mid$(varFilePath, lngDotPos)

            ' ファイル名を変更
            Name varFilePath As strNewFilePath
            lngRenameCount = lngRenameCount + 1

            ' エラーが発生した場合はエラー回数を記録
            If Err.Number <> 0 Then
                lngErrorCount = lngErrorCount + 1
                Err.Clear
            End If
        End If
    Next varFilePath

On Error GoTo LBL_ERROR

    '------------------------------
    ' 結果表示
    '------------------------------
    Dim strResult(3) As String
    strResult(0) = "ファイル名に日付を追加しました"
    strResult(1) = "実施回数：" & lngRenameCount
    strResult(2) = "成功数　：" & lngRenameCount - lngErrorCount
    strResult(3) = "エラー数：" & lngErrorCount
    MsgBox Join$(strResult, vbLf), vbInformation
    Exit Sub

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    MsgBox "エラー番号：" & Err.Number & vbLf & _
           Err.Description, vbExclamation, "エラーが発生しました"
End Sub