既存のExcelブックを上書きせずにコピーする

Question

フォルダXからフォルダYにExcelワークブックをコピーしようとしていますが、その名前のファイルがすでにフォルダYに存在する場合、そのファイルは上書きされません新しいファイルには ' - Copy'、 ' - Copy（2）'などの接尾辞が付いています。フォルダ内の同じファイルをコピーして貼り付ける手作業を本質的に作り直しています。

私はあなたがこれを行うことができますが、私がこれまで試してみました何が正確な要件に合うように思わない機能があるだろうと思っているだろう：

• Workbook.SaveAsがいるかどうかを確認するメッセージをユーザーに促しファイルは

• Workbook.SaveCopyAs

  は単にプロンプ​​ト

• FileSystemObject.CopyFile方法なしにファイルを上書きし交換する必要があります「上書き」パーを持っていますameter、Microsoft website

に応じて、既存のファイルの数に基づいて増加するカウンタを作成することは困難ではないであろう行動が期待されてfalseに設定し、ファイルが既に存在している場合しかし、これだけでエラー、選択したフォルダ（.xls（1）、.xls（2）など）にあるが、これよりも直接的なアプローチがあることを期待していた。

Answer 1

これはおそらく何か？ラッパーを置いてファイルとして保存ダイアログを表示し、選択したファイルパスからこれを実行する必要があります。

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 2

私は直接アプローチを見つけることができませんでした。以下のコードは、望ましい結果を提供します。 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