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

我正在尝试将Excel工作簿从文件夹X复制到文件夹Y，如果文件夹Y中已存在同名文件，则不会覆盖该文件，而是为新文件添加了一个后缀“-copy”、“-copy（2）”等-基本上是重新创建手动过程，以便在文件夹中复制和粘贴同一文件

我本以为会有一个函数允许您执行此操作，但到目前为止，我尝试的任何操作似乎都不符合确切的要求：

• Workbook.SaveAs

  向用户提示一条消息，询问是否应替换该文件

• Workbook.SaveCopyAs

  只需覆盖文件而无需提示

• FileSystemObject.CopyFile

  方法有一个“overwrite”参数，但是如果设置为false并且文件已经存在，则会出现错误，根据

---

创建一个计数器，根据所选文件夹中现有文件的数量（.xls（1），.xls（2）等）递增并不困难，但我希望有一种比这更直接的方法。

可能是这样的吗？您需要在其周围放置一个包装器，显示“文件另存为”对话框，然后在选定的文件路径下运行此操作

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

---

我没有找到任何直接的方法。下面的代码将给出所需的结果。由于fso对象对我不起作用，所以它比前一篇文章稍作修改

Public Function CUSTOM_SAVECOPYAS_FILENAME(strFilePath As String) As String
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
Dim pos As Integer 
Dim strFilePathNoFileName  As String
arrSplit = Split(strFilePath, "\")

pos = InStrRev(strFilePath, "\")
strFilePathNoFileName = Left(strFilePath, pos)

strFileName = arrSplit(UBound(arrSplit))
strFileNameNoExt = Split(strFileName, ".")(0)
strExtension = Split(strFileName, ".")(1)


intCounter = 1

If FileExists(strFilePath) = True Then
    'Set fl = FSO.GetFile(strFilePath)
    strNewFileName = strFilePathNoFileName & strFileNameNoExt & " (" & intCounter & ")." & strExtension
    Do
        blnNotFound = FileExists(strNewFileName)
        If blnNotFound Then intCounter = intCounter + 1
    Loop Until Not blnNotFound
Else
      strNewFileName = strFilePath
End If

'This function will return file path to main function where you save the file
CUSTOM_SAVECOPYAS_FILENAME = strNewFileName

End Function

Public Function FileExists(ByVal path_ As String) As Boolean
FileExists = (Len(Dir(path_)) > 0)
End Function

'main
Sub main()
'.......
str_fileName = "C:/temp/test.xlsx"
str_newFileName = CUSTOM_SAVECOPYAS_FILENAME(str_fileName)

Application.DisplayAlerts = False
NewWb.SaveAs str_newFileName
NewWb.Close
Application.DisplayAlerts = True
End Sub

---

这个函数对我有效，但经过了两步

步骤1：

进入VBE的菜单（工具->参考），然后在“Microsoft脚本运行时”旁边打勾

步骤2：

编辑代码， 事实上：

If FileExists(strFilePath) = True Then
   'Set fl = FSO.GetFile(strFilePath)
   strNewFileName = strFilePathNoFileName & strFileNameNoExt & " (" & intCounter & ")." & strExtension
   Do
       blnNotFound = FileExists(strNewFileName)
       If blnNotFound Then intCounter = intCounter + 1
   Loop Until Not blnNotFound
Else
     strNewFileName = strFilePath
End If

我猜您必须在循环中插入一行来更新新文件名，以检查是否存在。 因此，新的代码应该是：

   Do
       blnNotFound = FileExists(strNewFileName)
       If blnNotFound Then intCounter = intCounter + 1
       ' HERE :
       strNewFileName = fl.ParentFolder & "\" & strFileNameNoExt & " (" & intCounter & ")." & strExtension

   Loop Until Not blnNotFound

---

干得好，谢谢你。

在这里凭直觉行事。在我看来，最好的解决方案是在这里有自己的计数器并更改文件名。（我不知道该“作业”是否有vba函数，老实说，如果有，我会感到惊讶）使用

FileSystemObject

File.exists

方法，然后使用

regex

或

mid

instr

获取（x）如果有一个和增量，则进行编号。如果用户有3个文件-

Test

、

Test1

和

Test3

，会发生什么情况？第四个文件将给出一个错误？