ExcelVBAによる 上書き保存時の処理について

ExcelVBAによる 上書き保存時の処理について


先日、作業で使用するエクセルにて下記のようにSheet1というシートを保存するVBAを作成しました。

しかし、格納したいパスに同名のファイルが存在した場合、上書き確認メッセージ上で上書き保存をするか否かを確認するのですが
この時、「いいえ」を押下してしまうとそのまま、保存せず処理を終了してしまいます。

私としては、上書き保存を確認する際に「いいえ」を選択するともう一度「ファイルの新規保存」ダイアログを表示し、ファイル名の変更等を行えるようにしたいのですが、どの様にすれば良いのでしょうか？

一応、その時のコードを下記に掲載します。

Sheets("Sheet1").Copy

Sheets("Sheet1").Cells.Select
SaveName = Application.GetSaveAsFilename(filefilter:="Microsoft Office Excelブック,*.xls")

If SaveName <> "False" Then 'キャンセルが押下されたならば、一時保存用のExcelファイルを閉じる
If Dir(SaveName) <> "" Then
If MsgBox("同名ファイルがあります。上書きしますか？", vbYesNo) = vbNo Then
ActiveWorkbook.Close
End If
End If
End If
ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlNormal
End

No.1 ベストアンサー 回答者： kmetu 回答日時： 2010/07/05 21:54

必要な部分を　Do ～　Loopで囲んでやれば良いです。

Do
LoopFLG=FALSE
SaveName = Application.GetSaveAsFilename(filefilter:="Microsoft Office Excelブック,*.xls")

If SaveName <> "False" Then 'キャンセルが押下されたならば、一時保存用のExcelファイルを閉じる
If Dir(SaveName) <> "" Then
If MsgBox("同名ファイルがあります。上書きしますか？", vbYesNo) = vbNo Then
LoopFLG=TRUE
End If
End If
End If
Loop Until LoopFLG=TRUE

No.4 回答者： Wendy02 回答日時： 2010/07/06 10:46

ロジックとしては、上書きしますか？で、「はい」「いいえ」だけで、「ファイル新規保存」が出てきますと、見かけ上の無限ループが、「いいえ」側で発生しますから、「キャンセル」を設けます。

Sub MacroTest1()
　Dim SaveName As Variant
　Dim Fname As String
　Dim ret As VbMsgBoxResult
　Const EXT As String = "xls"
　
　Worksheets("Sheet1").Copy
　
　Do
　　SaveName = Application.GetSaveAsFilename(Fname, "Microsoft Office Excelブック,*.xls")
　　If VarType(SaveName) = vbBoolean Or SaveName = "" Then
　　　ActiveWorkbook.Close False
　　　Exit Sub
　　End If
　　If InStr(1, SaveName, EXT, 1) = 0 Then SaveName = SaveName & "." & EXT
　　Fname = Dir(SaveName)
　　If Fname <> "" Then
　　　ret = MsgBox("同名ファイルがあります。上書きしますか？(キャンセルは取りやめ）", vbYesNoCancel)
　　　If ret = vbCancel Then
　　　　ActiveWorkbook.Close
　　　　Exit Sub
　　　ElseIf ret = vbYes Then
　　　　Application.DisplayAlerts = False
　　　　ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlNormal
　　　　Application.DisplayAlerts = False
　　　　ActiveWorkbook.Close True
　　　　Exit Sub
　　　End If
　　End If
　Loop While Fname <> ""
　ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlNormal
　ActiveWorkbook.Close
End Sub

No.3 回答者： keithin 回答日時： 2010/07/06 01:17

まぁ，GoTo制御はダメとは言われますが。

Sub macro1()
　Dim SaveName As Variant

　Worksheets("Sheet1").Copy

roopStart:
　savename = Application.GetSaveAsFilename(filefilter:="Microsoft Office Excelブック,*.xls")

　If savename = False Then
　　ActiveWorkbook.Close False
　　Exit Sub
　End If

　If Dir(savename) <> "" Then
　　If MsgBox("同名ファイルがあります。上書きしますか？", vbYesNo) = vbNo Then GoTo roopStart
　End If

　Application.DisplayAlerts = False
　ActiveWorkbook.SaveAs Filename:=savename, FileFormat:=xlNormal
　Application.DisplayAlerts = True
End Sub

No.2 回答者： kmetu 回答日時： 2010/07/05 21:56

訂正です

Loop Until LoopFLG=TRUE

↓

Loop While LoopFLG=TRUE