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

问题描述：

我想将文件夹X中的Excel工作簿复制到文件夹Y，并且在文件夹Y中已存在该文件名的文件时，文件未被覆盖而是给新文件后缀' - 复制'，' - 复制（2）'等 - 基本上重新创建复制和粘贴文件夹中的相同文件的手动过程。保存现有Excel工作簿的副本而不覆盖它

我本来以为会有一个功能，可以让你做到这一点，但没有到目前为止，我已经尝试似乎符合具体要求：

Workbook.SaveAs提示用户有一条消息，询问是否该文件应更换
Workbook.SaveCopyAs简单地覆盖该文件而不提示
的FileSystemObject.CopyFile方法有一个“覆盖”帕ameter，然而，这只是错误，如果设置为false，该文件已经存在，它是根据Microsoft website

行为这不会是很难创造出增量基于现有文件数计数器预期在选定的文件夹（.xls（1），.xls（2）等）中，但我希望可能有一个比这更直接的方法。

在这里与你的直觉。 IMO最好的解决办法是在这里设置自己的柜台并更改名称文件。（我不知道是否有这个“工作”的vba函数，说实话，如果存在的话我会感到惊讶） – Blenikos

使用FileSystemObject File.Exists方法，然后使用regex或mid '/'instr'来获得（x）号码，如果有一个和增量。 –

答

也许这样的事情？您需要在它上面放置一个包装，将文件另存为对话框，然后从选定的文件路径运行。

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

如果用户有3个文件 - Test，Test1和Test3会发生什么？第四个文件会给出错误？ – Vityata

答

我没有找到任何直接的方法。下面的代码将给出所需的结果。由于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工作簿的副本而不覆盖它

相关推荐