Excel VBA 创建/覆盖新工作簿并使用取消按钮

Question

我编写了一个宏，它从一个工作簿中获取一个范围并复制到一个新工作簿中，然后将新创建的工作簿（并为其命名）保存到相同的文件夹路径中。当此工作簿已存在时（覆盖工作簿），会弹出默认窗口对话框询问您是否要覆盖，并选择是否取消按钮。按下取消按钮时，将创建一个新工作簿。如何编辑此代码，以便在按下取消时不会创建新工作簿？我在下面粘贴了宏：

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

在错误恢复下一个很少是一个好主意。如果用户选择否或取消，则会触发错误。更好地处理该错误以删除不需要的工作簿（尽管另一个想法是在创建之前测试具有目标名称的工作簿是否存在，如果存在，则使用 msgbox 询问用户是否要覆盖文件，如果所以，只有创建工作簿，禁用警报，然后才进行保存）。

一个问题似乎是您需要一个文件名才能杀死工作簿。在您的情况下，工作簿还没有文件名。一种解决方案是创建一个安全的文件名，其唯一目的是杀死不需要的工作簿，使用此名称再次执行另存为，然后将其杀死。像这样的：

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 2

这是一种可能的方法：

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 3

这是完整的代码

1. 检查文件是否已经存在
2. 如果存在关闭新书并询问您是否会打开已存在的文件
3. 关闭新书
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