保存现有Excel工作簿的副本而不覆盖它

我正在尝试将文件夹X中的Excel工作簿复制到文件夹Y，并且在文件夹Y中已经存在该文件名的文件时，文件不会被覆盖，而是为新文件提供后缀“ – 复制” ，' – 复制（2）'等 – 基本上重新创build复制和粘贴文件夹中的同一个文件的手动过程。

我会认为会有一个function，让你做到这一点，但我迄今为止所尝试的东西似乎符合确切的要求：

• Workbook.SaveAs提示信息询问用户是否应该replace文件

• Workbook.SaveCopyAs只是在不提示的情况下覆盖文件

• FileSystemObject.CopyFile方法有一个'覆盖'参数，但是这只是错误，如果设置为false，并且该文件已经存在，这是根据Microsoft网站

创build一个基于所选文件夹（.xls（1），.xls（2）等）中现有文件数量递增的计数器并不困难，但是我希望可以有一个更直接的方法这个。

Answer 1

这样的事情可能吗？ 你需要在它上面放一个包装，将文件另存为对话框，然后从选定的文件path中运行。

 Public Function CUSTOM_SAVECOPYAS(strFilePath As String) Dim FSO As Scripting.FileSystemObject Dim fl As Scripting.File Dim intCounter As Integer Dim blnNotFound As Boolean Dim arrSplit As Variant Dim strNewFileName As String Dim strFileName As String Dim strFileNameNoExt As String Dim strExtension As String arrSplit = Split(strFilePath, "\") strFileName = arrSplit(UBound(arrSplit)) strFileNameNoExt = Split(strFileName, ".")(0) strExtension = Split(strFileName, ".")(1) Set FSO = New Scripting.FileSystemObject intCounter = 1 If FSO.FileExists(strFilePath) Then Set fl = FSO.GetFile(strFilePath) strNewFileName = fl.Path & "\" & strFileNameNoExt & " (" & intCounter & ")." & strExtension Do blnNotFound = Not FSO.FileExists(strNewFileName) If Not blnNotFound Then intCounter = intCounter + 1 Loop Until blnNotFound Else strNewFileName = strFilePath End If ThisWorkbook.SaveCopyAs strNewFileName set fso=nothing set fl =nothing End Function