保存現有Excel工作簿的副本而不覆蓋它

我想將文件夾X中的Excel工作簿複製到文件夾Y，並且在文件夾Y中已存在該文件名的文件時，文件未被覆蓋而是給新文件後綴' - 複製'，' - 複製（2）'等 - 基本上重新創建複製和粘貼文件夾中的相同文件的手動過程。保存現有Excel工作簿的副本而不覆蓋它

我本來以爲會有一個功能，可以讓你做到這一點，但沒有到目前爲止，我已經嘗試似乎符合具體要求：

Workbook.SaveAs提示用戶有一條消息，詢問是否該文件應更換
Workbook.SaveCopyAs簡單地覆蓋該文件而不提示
的FileSystemObject.CopyFile方法有一個「覆蓋」帕ameter，然而，這只是錯誤，如果設置爲false，該文件已經存在，它是根據Microsoft website

行爲這不會是很難創造出增量基於現有文件數計數器預期在選定的文件夾（.xls（1），.xls（2）等）中，但我希望可能有一個比這更直接的方法。

來源

2016-11-14 finjo

在這裏與你的直覺。 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

來源

2016-11-14 10:14:14

如果用戶有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

來源

2018-01-30 11:26:34

保存現有Excel工作簿的副本而不覆蓋它

回答

相關問題