excelのThisWorkbookに放り込んでおいてカレントに「old」フォルダを作っておくとセーブの度に履歴を「old」フォルダに保存して「保存しました」と喋ってくれるVBAのテスト

Public Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Const FOLD_NAME = "old"

Dim fold_path As String
Dim fold_path2 As String
Dim objFileSys
Dim strPath
Dim Y As String
Dim m As String
Dim d As String
Dim h As String
Dim s As String
Dim wb As String
Dim path2 As String

Dim Speaker

Dim wShell

Set objFileSys = CreateObject("Scripting.FileSystemObject")

Set Speaker = CreateObject("sapi.spvoice")
Speaker.Rate = -1
Speaker.Volume = 100

strPath = objFileSys.GetExtensionName(ActiveWorkbook.Name)
strPath = "." & strPath

Y = Format(Now, "yyyy")
m = Format(Now, "MM")
d = Format(Now, "DD")
h = Format(Now, "HH")
MM = Format(Now, "NN")

fold_path2 = ActiveWorkbook.Path & "\" & FOLD_NAME
fold_path = ActiveWorkbook.Path & "\" & FOLD_NAME & "\" & Y & "\" & m

If Dir(fold_path2, vbDirectory) = "" Then
Exit Sub
Else
If Dir(fold_path2, vbDirectory) = FOLD_NAME Then

CreateFolder (fold_path)

End If

wb = Replace(ActiveWorkbook.Name, strPath, "")

path2 = ActiveWorkbook.Path & "\" & FOLD_NAME & "\" & Y & "\" & m & "\" & wb & _
Format(Now(), "_yyyymmdd_hhmmss") & strPath

ActiveWorkbook.SaveCopyAs Filename:=path2

Dim myShell As Object
Set myShell = CreateObject("Wscript.Shell")
myShell.PopUp "保存しました", 1, "1秒で窓は閉じます"


'Set wShell = CreateObject("WScript.Shell")
'最大音量

'wShell.Run "sndvol.exe"
'Application.Wait Now() + TimeValue("00:00:02")
'wShell.SendKeys "{home}{esc}"

'最小音量
'Set wShell = CreateObject("WScript.Shell")
'wShell.Run "sndvol.exe"
'Application.Wait Now() + TimeValue("00:00:02")
'wShell.SendKeys "{end}{esc}"

Speaker.Speak "保存しました"

Set myShell = Nothing

End Sub

Public Function CreateFolder(strFolderPath As String)

' パスを\区切りで分ける
Dim varFolders As Variant ' フォルダ名リスト
varFolders = Split(strFolderPath, "\")

' FileSystemObjectをインスタンス化する
Dim objFileSystemObject As Object ' FileSystemObjectオブジェクト
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")

' フォルダを作成する
Dim varValue As Variant ' フォルダ名リストから取り出したフォルダ名
Dim strValue As String ' CreateFolder()の戻り値
For Each varValue In varFolders
' 上位層からのフォルダパスを作る
strCurrentPath = strCurrentPath & varValue & "\"
' フォルダがあるかチェックする
On Error Resume Next
If objFileSystemObject.FolderExists(strCurrentPath) = False Then
' フォルダがなかったら新しく作る
strValue = objFileSystemObject.CreateFolder(strCurrentPath)
End If
' エラーをチェックする
If Err <> 0 Then
' フォルダの作成に失敗したらFor文を終了する
' MsgBox "フォルダの作成に失敗しました"
Exit For
End If
Next

' 使い終わったら必ずNothingを設定する
Set objFileSystemObject = Nothing

End Function

音声ルーチンは蛇足のような気がするので削除して良いかもしれません（入れたのは単なる趣味です）
ただ動的な内容を変数に入れておけばそれを喋ってくれますので色々応用は利くかと

このサイトに掲載のスクリプト・手順など全ての情報については、一切の保証が無いものとしてご利用下さい。PCの不具合、動作、データの破損などについて責任を負うことはできません。あくまでも自己責任となります。