Question

我正在尝试将Excel工作簿从文件夹X复制到文件夹Y，如果文件夹Y中已存在该文件的文件，则文件不会被覆盖，而是新文件的后缀为＆＃39; - 复制＆＃39;，＆＃39; - 复制（2）＆＃39;等 - 基本上重新创建手动过程，用于复制和粘贴文件夹中的同一文件。

我原以为会有一个功能允许你这样做，但到目前为止我没有尝试过的任何东西似乎符合确切的要求：

Workbook.SaveAs会提示用户询问是否应更换该文件
Workbook.SaveCopyAs只是在没有提示
FileSystemObject.CopyFile方法有一个＆＃39;覆盖＆＃39;参数，但这只是错误，如果设置为false并且文件已经存在，这是根据Microsoft website

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

Answer 1

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

第1步：

进入VBE的菜单（工具 - ＆gt;参考），然后在“Microsoft Scripting Run-time”旁边放置一个复选标记。

第2步：

编辑代码，原来是：

display:flex;
justify-content:space-between;

我猜你必须在INSOP INSIDE THE LOOP中更新新文件名，以便检查是否存在。所以新的代码应该是：

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

很好的工作，谢谢。

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

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

3 个答案: