请求开发宏：每隔指定时间保存.xlsm工作表为.xlsx，运行结束后终止自动保存

没问题，我帮你搞定这个定时备份的需求！下面是一套完整的实现方案，包含代码和详细说明，刚好适配你的场景：

核心实现思路 #

• 利用Excel的Application.OnTime方法创建定时任务，每隔指定时间自动触发备份
• 用全局变量记录下一次备份的触发时间，方便宏结束时取消定时任务
• 备份时将目标工作表复制到新工作簿，另存为.xlsx格式（避免宏代码被保存进去），文件名带上时间戳防止覆盖

完整代码（粘贴到标准模块中） #

打开Excel按Alt+F11进入VBA编辑器，插入一个标准模块（右键工程→插入→模块），然后粘贴以下代码：

' 全局变量：存储下一次自动备份的时间，用于后续取消定时任务
Dim nextBackupTime As Date

' 启动自动备份
' 参数intervalMinutes：备份间隔分钟数（默认30分钟）
' 参数targetSheetName：需要备份的工作表名称
' 参数backupFolder：备份文件保存路径（默认和原工作簿同目录）
Sub StartAutoBackup(Optional intervalMinutes As Integer = 30, Optional targetSheetName As String = "预测数据", Optional backupFolder As String = "")
    ' 如果未指定备份路径，默认使用当前工作簿所在目录
    If backupFolder = "" Then
        backupFolder = ThisWorkbook.Path & "\"
    End If
    
    ' 创建下一次备份的时间
    nextBackupTime = Now + TimeValue("00:" & intervalMinutes & ":00")
    
    ' 注册定时任务
    Application.OnTime EarliestTime:=nextBackupTime, Procedure:="BackupPredictionData", _
        Schedule:=True, Argument:=targetSheetName & "|" & backupFolder & "|" & intervalMinutes
    
    MsgBox "自动备份已启动，每隔" & intervalMinutes & "分钟备份一次！", vbInformation
End Sub

' 执行备份操作
Sub BackupPredictionData(args As String)
    ' 解析传入的参数：工作表名称|备份路径|间隔分钟数
    Dim params As Variant
    params = Split(args, "|")
    Dim targetSheetName As String: targetSheetName = params(0)
    Dim backupFolder As String: backupFolder = params(1)
    Dim intervalMinutes As Integer: intervalMinutes = CInt(params(2))
    
    On Error Resume Next
    ' 检查目标工作表是否存在
    If Not SheetExists(targetSheetName) Then
        MsgBox "备份失败：未找到工作表「" & targetSheetName & "」", vbCritical
        Exit Sub
    End If
    
    ' 创建新工作簿，复制目标工作表到新工作簿
    Dim newWB As Workbook
    Set newWB = Workbooks.Add
    ThisWorkbook.Sheets(targetSheetName).Copy Before:=newWB.Sheets(1)
    
    ' 删除新工作簿默认的空白工作表
    Application.DisplayAlerts = False
    For Each ws In newWB.Sheets
        If ws.Name <> targetSheetName Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
    
    ' 生成带时间戳的备份文件名
    Dim backupFileName As String
    backupFileName = backupFolder & "预测数据备份_" & Format(Now, "YYYYMMDD_HHMMSS") & ".xlsx"
    
    ' 保存并关闭备份工作簿
    newWB.SaveAs Filename:=backupFileName, FileFormat:=xlOpenXMLWorkbook
    newWB.Close SaveChanges:=False
    
    ' 重新注册下一次备份任务
    nextBackupTime = Now + TimeValue("00:" & intervalMinutes & ":00")
    Application.OnTime EarliestTime:=nextBackupTime, Procedure:="BackupPredictionData", _
        Schedule:=True, Argument:=targetSheetName & "|" & backupFolder & "|" & intervalMinutes
        
    On Error GoTo 0
End Sub

' 停止自动备份
Sub StopAutoBackup()
    On Error Resume Next
    ' 取消已注册的定时任务
    Application.OnTime EarliestTime:=nextBackupTime, Procedure:="BackupPredictionData", Schedule:=False
    On Error GoTo 0
    
    MsgBox "自动备份已终止！", vbInformation
End Sub

' 辅助函数：检查工作表是否存在
Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function

' ------------------- 示例：你的长时间运行预测宏 -------------------
Sub RunLongPrediction()
    ' 1. 启动自动备份（这里可以自定义参数，比如改成15分钟备份一次）
    StartAutoBackup intervalMinutes:=30, targetSheetName:="预测数据", backupFolder:="C:\预测备份\"
    
    ' 2. 这里写你的预测宏核心代码（比如循环处理多年数据）
    ' 示例：模拟长时间运行（实际替换成你的业务逻辑）
    Dim i As Long
    For i = 1 To 100000000
        ' 你的数据处理代码...
        DoEvents ' 防止Excel假死，让系统响应操作
    Next i
    
    ' 3. 宏运行完成后，停止自动备份
    StopAutoBackup
    MsgBox "预测任务已完成！", vbInformation
End Sub

代码说明 #

1. StartAutoBackup：初始化定时任务，你可以自定义备份间隔、目标工作表和保存路径，默认30分钟备份到原工作簿目录
2. BackupPredictionData：实际执行备份的函数，会自动创建带时间戳的备份文件，避免覆盖旧备份，完成后自动注册下一次备份
3. StopAutoBackup：取消定时任务，必须在宏正常结束时调用，防止Excel关闭后仍触发备份
4. SheetExists：辅助函数，避免因工作表不存在导致备份失败
5. RunLongPrediction：示例宏，展示了如何在你的核心业务代码前后启动/停止自动备份

使用注意事项 #

• 确保备份路径存在：如果指定了自定义备份路径（比如C:\预测备份\），要先手动创建这个文件夹，否则备份会失败
• 宏运行时尽量不要手动关闭Excel：如果意外中断，记得手动运行StopAutoBackup取消定时任务，否则Excel下次打开可能会自动触发备份
• 启用宏：保存工作簿为.xlsm格式，打开时要启用宏才能正常运行
• 时间戳格式：代码中用了YYYYMMDD_HHMMSS，你可以根据需要修改Format(Now, "这里改成你要的格式")

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