Excel VBA创build/覆盖新工作簿并使用取消button

我有一个写入macros的范围从一个工作簿复制到一个新的工作簿，然后将新创build的工作簿（并给它一个名称）到同一个文件夹path。 当这个工作簿已经存在时，（覆盖工作簿），popup默认的窗口对话框，询问你是否要覆盖，是否不取消buttonselect。 当按下取消button时，将创build一个新的工作簿。 如何编辑此代码以便按下取消时，不会创build新的工作簿？ 我已经粘贴了下面的macros：

Sub ExportNewBook() Application.ScreenUpdating = False Dim ThisWB As Workbook Set ThisWB = ActiveWorkbook Set NewBook = Workbooks.Add On Error Resume Next ThisWorkbook.Worksheets("Summary").Range("A1:I100").Copy NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues) NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats) NewBook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit NewBook.SaveAs Filename:=ThisWB.Path & "\" & NewBook.Worksheets("Sheet1").Range("A4").Value & "_Summary" NewBook.ActiveSheet.Range("A1").Select Application.ScreenUpdating = True End Sub 

编辑：工作代码如下所示

 Sub ExportNewBook() Application.ScreenUpdating = False Dim ThisWB As Workbook Dim fname As String Set ThisWB = ActiveWorkbook Set Newbook = Workbooks.Add ThisWorkbook.Worksheets("Summary").Range("A1:I100").Copy Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues) Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats) Newbook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit fname = ThisWB.Path & "\" & ThisWB.Worksheets("Summary").Range("A4").Value & "_Summary.xls" If Dir(fname) <> "" Then If MsgBox("Summary output already exists, are you sure you want to overwrite?", vbOKCancel) = vbCancel Then Newbook.Close False: Application.CutCopyMode = False: Exit Sub End If Application.DisplayAlerts = False Newbook.SaveAs Filename:=fname Application.DisplayAlerts = True ThisWB.Activate ActiveWorkbook.Worksheets("Summary").Range("A1").Select Newbook.Activate ActiveWorkbook.ActiveSheet.Range("A1").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub 

谢谢！

Answer 1

这是一个可能的方法：

 Sub ExportNewBook() Application.ScreenUpdating = False Dim ThisWB As Workbook, Newbook As Workbook Dim fname As String Set ThisWB = ActiveWorkbook fname = ThisWB.Path & "\" & ThisWB.Sheets("Sheet1").Range("A4").Value & "_Summary" If Dir(fname) <> "" Then If MsgBox("Are you sure you want to overwrite?", vbOKCancel) = vbCancel Then Exit Sub End If Set Newbook = Workbooks.Add ThisWB.Worksheets("Summary").Range("A1:I100").Copy Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues) Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats) Newbook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit 'This code should be faster since it bypasses the copy-paste buffer 'With Newbook.Sheets(1) ' ThisWB.Sheets("Summary").Range("A1:I100").Copy .Range("A1") ' .Range("A1:I100").Value = .Range("A1:I100").Value ' .Columns.AutoFit 'End With Application.DisplayAlerts = False Newbook.SaveAs Filename:=fname Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub 

Answer 2

接下来的错误恢复很less是一个好主意。 如果用户select否或取消，则会触发错误。 更好地处理该错误以删除不需要的工作簿（尽pipe另一个想法是在创build之前testing是否存在具有目标名称的工作簿，如果是，则使用msgbox询问用户是否要覆盖文件，如果所以，只有然后创build工作簿，禁用警报，只有然后做save​​as）。

一个问题似乎是你需要有一个文件名来杀死一个工作簿。 在你的情况下，工作簿还没有文件名。 一个解决scheme是创build一个安全的文件名，其唯一目的是杀死一个不需要的工作簿，然后用这个名字再次保存，然后杀死它。 像这样的东西：

 Sub Test() On Error GoTo err_handler Dim wb As Workbook Dim fname As String Dim tempname As String fname = "C:\Programs\testbook.xlsx" Set wb = Workbooks.Add wb.Sheets(1).Range("A1").Value = Now 'for testing purposes wb.SaveAs fname Exit Sub err_handler: tempname = "C:\Programs\name_i_will_never_use.xlsx" wb.SaveAs tempname wb.Close Kill tempname End Sub 

Answer 3

这是完整的代码

1. 检查文件是否已经存在
2. 如果存在closures新书并询问您是否存在的文件将被打开
3. closures新书
4. 在错误的情况下在扩展文件之前保存带有（错误）后缀的新书

 Sub ExportNewBook() Application.ScreenUpdating = False Dim ThisWB As Workbook Dim NewName As String Set ThisWB = ActiveWorkbook Set NewBook = Workbooks.Add On Error GoTo err_handler ThisWB.Worksheets("Summary").Range("A1:I100").Copy NewBook.Worksheets("Foglio1").Range("A1").PasteSpecial (xlPasteValues) NewBook.Worksheets("Foglio1").Range("A1").PasteSpecial (xlPasteFormats) NewBook.Worksheets("Foglio1").Range("A:J").Columns.AutoFit NewName = ThisWB.Path & "\" & NewBook.Worksheets("Foglio1").Range("A4").Value & "_Summary.xls" If Dir(NewName) "" Then If MsgBox("A file named '" & NewName & " already exists." & vbCr & vbCr & _ MeaName & " will now open??", vbYesNo) = vbYes Then Workbooks.Open NewName End If NewBook.Close False Exit Sub End If NewBook.SaveAs Filename:=NewName NewBook.ActiveSheet.Range("A1").Select NewBook.Close Application.ScreenUpdating = True err_handler: NewName = ThisWB.Path & "\" & NewBook.Worksheets("Foglio1").Range("A4").Value & "_Summary(error).xls" NewBook.SaveAs Filename:=NewName NewBook.ActiveSheet.Range("A1").Select NewBook.Close Application.ScreenUpdating = True End Sub