Question

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

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询问用户是否要覆盖该文件，如果所以，只有这样才能创建工作簿，禁用警报，然后才能执行saveas）。

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

increase_counter

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

这是

的完整代码

检查文件是否已存在
如果存在，请关闭新书并询问您是否将打开现有文件
关闭新书
如果出错，请在扩展文件

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

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

3 个答案: