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

Question

我正在尝试将 Excel 工作簿从文件夹 X 复制到文件夹 Y，如果文件夹 Y 中已存在同名文件，则不会覆盖该文件，而是为新文件提供后缀“ - Copy'、'- Copy (2)' 等 - 本质上是重新创建手动过程，用于在文件夹中复制和粘贴同一文件。

我原以为会有一个功能可以让你做到这一点，但到目前为止我没有尝试过似乎符合确切要求：

• Workbook.SaveAs 向用户提示是否应替换文件的消息

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

1234563

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

Answer 1

该功能对我有用，但经过两个步骤。

第 1 步：

进入 VBE 的菜单（工具 -> 参考），然后在“Microsoft Scripting Run-time”旁边打勾。

第 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

干得好，谢谢。

Answer 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

Answer 3

我没有找到任何直接的方法。下面的代码将给出所需的结果。由于 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