vba 保存文件时进行备份的宏
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/15267796/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Macro to make a backup while saving a file
提问by mgunia
I would like to have a macro which automatically makes the backup of my file to a different folder when it is being saved. I have found a working macro but it makes a copy each time when I run it (not automatically when file is being saved). Could anyone help me to amend the macro code to work as I described?
我想要一个宏，它在保存文件时自动将我的文件备份到不同的文件夹。我找到了一个可以工作的宏，但每次运行时它都会复制一份（保存文件时不会自动）。任何人都可以帮助我修改宏代码以按照我的描述工作吗？
MACRO I HAVE:
宏我有：
Sub Auto_Save()
Dim savedate
savedate = Date
Dim savetime
savetime = Time
Dim formattime As String
formattime = Format(savetime, "hh.MM.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD - MM - YYYY")
Application.DisplayAlerts = False
Dim backupfolder As String
backupfolder = "Z:\My Documents\"
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & formatdate & " " & formattime & " " & ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
MsgBox "Backup Run. Please Check at: " & backupfolder & " !"
End Sub
回答by Olle Sj?gren
You mean you just want one backup-file with the same name as the original? Just remove the date and time from filename of the backup copy:
你的意思是你只想要一个与原文件同名的备份文件？只需从备份副本的文件名中删除日期和时间：
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & ActiveWorkbook.Name
You should also add some kind of error handling in case the backup file is open when trying to save etc.
您还应该添加某种错误处理，以防备份文件在尝试保存等时打开。
EDIT(updated based on new input)
编辑（根据新输入更新）
OK, then you need to trap an event. I've tried with the BeforeSaveevent and it works. There is also an AfterSaveevent you could try.
好的，那么您需要捕获一个事件。我已经尝试过该BeforeSave事件并且它有效。还有一个AfterSave你可以尝试的事件。
Add the following to the ThisWorkbookmodule:
将以下内容添加到ThisWorkbook模块中：
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim backupfolder As String
backupfolder = "Z:\My Documents\"
ThisWorkbook.SaveCopyAs Filename:=backupfolder & ThisWorkbook.Name
End Sub
回答by Hyman Geiger
Here's the code I created to backup my workbooks. It will create a subdirectory for your backups if it doesn't exist, and save backups to that directory.
这是我创建的用于备份工作簿的代码。如果它不存在，它将为您的备份创建一个子目录，并将备份保存到该目录。
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
thisPath = ThisWorkbook.Path
myName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
ext = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
backupdirectory = myName & " backups"
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(ThisWorkbook.Path & "/" & backupdirectory) Then
FSO.CreateFolder (ThisWorkbook.Path & "/" & backupdirectory)
End If
T = Format(Now, "mmm dd yyyy hh mm ss")
ThisWorkbook.SaveCopyAs thisPath & "\" & backupdirectory & "\" & myName & " " & T & "." & ext
Application.EnableEvents = True
End Sub
