如何用VBA按前一工作日或单元格值自动重命名保存Excel文件

1. 核心重命名保存逻辑 #

以下代码可直接嵌入目标Excel文件的模块中，结合现有刷新逻辑实现重命名保存。

按前一工作日日期重命名 #

Sub SaveWithPreviousWorkdayName()
    Dim originalPath As String
    Dim newFileName As String
    Dim previousWorkday As Date
    
    ' 获取原文件所在目录
    originalPath = ThisWorkbook.Path & "\"
    
    ' 计算前一工作日（默认排除周六周日，需自定义节假日可添加参数）
    previousWorkday = WorksheetFunction.WorkDay(Date, -1)
    
    ' 生成自定义格式的文件名（可按需修改前缀和日期格式）
    newFileName = originalPath & "日常报表_" & Format(previousWorkday, "YYYYMMDD") & ".xlsx"
    
    ' 执行数据刷新（替换为你已有的刷新逻辑，比如RefreshAll或特定连接刷新）
    ThisWorkbook.RefreshAll
    ' 等待数据刷新完成（根据数据量调整等待时长）
    Application.Wait Now + TimeValue("00:00:05")
    
    ' 另存为新文件
    ThisWorkbook.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook
    
    ' 关闭原文件（无需保存，因为已另存为新文件）
    ThisWorkbook.Close SaveChanges:=False
End Sub

若需排除自定义节假日，可修改WorkDay函数为：
previousWorkday = WorksheetFunction.WorkDay(Date, -1, ThisWorkbook.Sheets("设置").Range("A1:A20"))
其中A1:A20为存放节假日日期的单元格范围。

按指定单元格值重命名 #

如果需要基于工作表中特定单元格的值作为文件名一部分，可使用以下代码：

Sub SaveWithCellValueName()
    Dim originalPath As String
    Dim newFileName As String
    Dim cellValue As String
    
    originalPath = ThisWorkbook.Path & "\"
    
    ' 获取指定单元格的值（示例为Sheet1的A1单元格，按需修改）
    cellValue = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
    
    ' 清理文件名非法字符（避免因特殊字符导致保存失败）
    cellValue = Replace(Replace(Replace(Replace(Replace(Replace(cellValue, "/", "-"), "\", "-"), ":", "-"), "*", "-"), "?", "-"), """", "-")
    
    ' 生成文件名
    newFileName = originalPath & "日常报表_" & cellValue & ".xlsx"
    
    ' 数据刷新逻辑
    ThisWorkbook.RefreshAll
    Application.Wait Now + TimeValue("00:00:05")
    
    ThisWorkbook.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook
    ThisWorkbook.Close SaveChanges:=False
End Sub

2. 整合到任务计划器工作流 #

你现有任务计划器调用的VBA代码可修改为直接触发上述宏，示例如下：

Sub AutoRunFromScheduler()
    Dim targetWB As Workbook
    ' 替换为你的原文件路径
    Set targetWB = Workbooks.Open("C:\报表目录\原文件.xlsm")
    
    ' 运行重命名保存宏（二选一）
    targetWB.Application.Run "SaveWithPreviousWorkdayName"
    ' targetWB.Application.Run "SaveWithCellValueName"
    
    ' 可选：触发邮件发送宏
    ' targetWB.Application.Run "SendReportEmail"
End Sub

3. 自动发送邮件补充代码 #

若需完成保存后自动发送邮件，可添加以下宏（依赖Outlook）：

Sub SendReportEmail()
    Dim olApp As Object
    Dim olMail As Object
    Dim reportFullPath As String
    
    ' 获取刚保存的报表路径
    reportFullPath = ThisWorkbook.FullName
    
    ' 初始化Outlook对象
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    With olMail
        .To = "收件人邮箱@domain.com"
        .CC = "抄送人邮箱@domain.com"
        .Subject = "每日工作日报表 - " & Format(WorksheetFunction.WorkDay(Date, -1), "YYYY年MM月DD日")
        .Body = "您好，附件为最新的工作日报表，请查收。"
        .Attachments.Add reportFullPath
        .Send ' 直接发送；如需预览可改为.Display
    End With
    
    ' 释放对象
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

关键注意事项 #

• 确保目标Excel文件保存为.xlsm格式（支持宏），且已启用宏
• 任务计划器运行的账户需拥有文件目录读写权限，以及Outlook的访问权限
• 数据刷新等待时长可根据实际数据量调整，或使用更精准的刷新完成判断（如针对Power Query连接：With ThisWorkbook.Connections("Power Query 连接").OLEDBConnection: .Refresh: Do While .Refreshing: DoEvents: Loop: End With）
• 文件名格式可根据业务需求自由调整（如修改Format函数的日期格式参数）

内容的提问来源于stack exchange，提问作者user29930398