VBA 宏将 Excel 文件保存到不同的备份位置

Question

我正在尝试创建一个在关闭或保存时运行的宏，以将文件备份到不同的位置。
目前我使用的宏是：

Private Sub Workbook_BeforeClose(Cancel As Boolean)  
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)  
    'Saves the current file to a backup folder and the default folder  
    'Note that any backup is overwritten  
    Application.DisplayAlerts = False  
    ActiveWorkbook.SaveCopyAs Filename:="T:\TEC_SERV\Backup file folder - DO NOT DELETE\" & _ 
    ActiveWorkbook.Name  
    ActiveWorkbook.Save  
    Application.DisplayAlerts = True  
End Sub  

第一次可以创建文件的备份，但是如果再次尝试，我会得到：

运行时错误“1004”；
Microsoft Office Excel 无法访问文件“T:\TEC_SERV\Backup 文件夹 - 不要删除\Test Macro Sheet.xlsm”。可能的原因有以下几个：
文件名或路径不存在
该文件正在被另一个程序使用
您尝试保存的工作簿与...同名

我知道路径是正确的，我也知道该文件在其他地方没有打开。该工作簿与我尝试保存的工作簿具有相同的名称，但它应该被覆盖。

Answer 1

我将代码修改为：

Sub BUandSave2()
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Saves the current file to a backup folder and the default folder
'Note that any backup is overwritten
Dim MyDate
MyDate = Date    ' MyDate contains the current system date.
Dim MyTime
MyTime = Time    ' Return current system time.
Dim TestStr As String
TestStr = Format(MyTime, "hh.mm.ss")
Dim Test1Str As String
Test1Str = Format(MyDate, "DD-MM-YYYY")

Application.DisplayAlerts = False
'
Application.Run ("SaveFile")
'
ActiveWorkbook.SaveCopyAs Filename:="T:\TEC_SERV\Backup Test\" & Test1Str & " " & TestStr & " " & ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub

现在工作正常。大学网络上一定有什么东西阻止了原始版本的运行。我在家没遇到任何问题。

Answer 2

我尝试了你编写的代码，发现代码有效，但是当我打开备份文件时，我得到了与你相同的错误。

所以我认为您在出现错误时一定已经打开了备份文件。

我编写了一段代码来帮助解决此错误：

If ActiveWorkbook.Path = "D:\MOVIES\excel test\Backup" Then
    Exit Sub
Else
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveCopyAs Filename:="D:\MOVIES\excel test\Backup\" & _
    ActiveWorkbook.Name
    ActiveWorkbook.Save
    Application.DisplayAlerts = True

我不认为大学网络有什么问题。

Answer 3

只是为了完成 joe 和 kishlaymshr 的优秀代码，让代码更加清晰，谢谢！:

Sub AutoBackup()

    If ActiveWorkbook.Path = "F:\TEMP\" Then

        Exit Sub

    Else

        Dim MyDate
        MyDate = Date    ' MyDate contains the current system date.
        Dim MyTime
        MyTime = Time    ' Return current system time.
        Dim TestStr As String
        TestStr = Format(MyTime, "hh.mm.ss")
        Dim Test1Str As String
        Test1Str = Format(MyDate, "DD-MM-YYYY")
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveCopyAs Filename:="F:\TEMP\" & _
           Test1Str & "-" & TestStr & "-" & ActiveWorkbook.Name
        ActiveWorkbook.Save
        Application.DisplayAlerts = True
    End If

End Sub