VBA条件另存为date添加

我正在使用Excel 2010，并试图使用以下macros：

1. 打开另存为对话框
2. 取最初的文件名，并检查在文件types（即.xlsx）之前是否有下划线，后面跟着8个连续的整数（即_12345678）
3. 如果确实存在，则在文件types（即.xlsx）之前删除并用“yyyymmdd”格式（即_20130730）的下划线后面加上今天的date，
4. 如果不存在，只需在文件types（即.xlsx）之前以“yyyymmdd”格式（即_20130730）添加下划线，
5. 基于上述条件的新文件名将出现在打开的“另存为”对话框的“文件名”字段中，但该文件将要求用户实际保存它（只是命名和打开“另存为”，实际上不是用VBA保存）
6. 保持原始文件types

假设今天的date是2013年7月30日，macros将按以下方式工作：
1.） testing文件A_20130615.xlsx将成为testing文件A_20130730.xlsx
2.） testing文件B.xlsx将成为testing文件B_20130730.xlsx

任何和所有的帮助表示赞赏！ 谢谢

Answer 1

我修改了一个例程，它具有与您正在尝试执行的操作相同types的操作，但使用文件的当前名称，而不是具有2个保存对话框。

Option Explicit Function SaveIt() Dim CurrentFile As String Dim FileExt As String Dim GetFileName CurrentFile = Left(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, ".") - 1) FileExt = Mid(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, ".")) If InStr(CurrentFile, "_") Then 'has underscore If InStrRev(CurrentFile, "_") = Len(CurrentFile) - 8 Then ' underscore 8 from end If Right(CurrentFile, 8) = CStr(Val(Right(CurrentFile, 8))) Then ' and it's 8 digits at the end CurrentFile = Left(CurrentFile, Len(CurrentFile) - 9) 'strip the end off End If ' if it fails any of these tests, End If 'then it's not got the underscore and date End If ' and we don't touch the filename CurrentFile = CurrentFile & "_" & Format(Now, "yyyymmdd") GetFileName = Application.GetSaveAsFilename(CurrentFile & FileExt) If GetFileName <> False Then 'Cancel returns false, otherwise it returns the filename ActiveWorkbook.SaveAs GetFileName End If End Function 

这也允许人们拥有名为test_1.xlsx和What_a_lot_of_underscores.xlsm的文件，而不必担心破坏名称