使用 VBA 和按钮将单个工作表导出到新工作簿

Question

我有一个带有按钮的工作表，一旦单击它就会将该工作表导出到一个新工作簿中，并允许用户将新工作簿保存到他们指定的位置。

在升级到 excel 2016 之前，此代码运行良好，但现在它遇到了我的错误处理程序。我对 VBA 相当陌生，并没有一开始就创建此代码，所以我不确定是否有更简单的方法，或者我是否只需要为 2016 用户输入一个新案例以及新代码应该说什么。

这是当前代码：

Private Sub SaveIt(SaveName As String)
Dim Fullname As String
Dim FileName As String
Dim Result As String
On Error GoTo ErrHandler

SaveName = SaveName & "\Premium Comparison"
Select Case Int(Application.Version)
  Case 11
   Application.Dialogs(xlDialogSaveAs).Show arg1:=SaveName ', arg2:=56, no arg2 is used in 2003,arg2 is to save 2003 in excel 2010
  Case 14
   Application.DisplayAlerts = False
   Result = Application.Dialogs(xlDialogSaveAs).Show(arg1:=SaveName, arg2:=51)   'xlsx format in 2010
   If Result Then
    Fullname = ActiveWorkbook.Fullname
    FileName = ActiveWorkbook.Name
    Application.Workbooks(FileName).Close SaveChanges:=False
    Application.Workbooks.Open FileName:=Fullname, UpdateLinks:=False
    Application.DisplayAlerts = True
   Else
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
   End If
  Case 15
   Application.DisplayAlerts = False
   Result = Application.Dialogs(xlDialogSaveAs).Show(arg1:=SaveName, arg2:=51)   'xlsx format in 2010
   If Result Then
    Fullname = ActiveWorkbook.Fullname
    FileName = ActiveWorkbook.Name
    Application.Workbooks(FileName).Close SaveChanges:=False
    Application.Workbooks.Open FileName:=Fullname, UpdateLinks:=False
    Application.DisplayAlerts = True
   Else
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
   End If
  Case Else
   MsgBox "Invalid excel version - " & Application.Version
End Select
Workbooks(CWName).Worksheets("Premium Comparison").Protect "Racers"
Exit Sub
ErrHandler:
'User pressed the Cancel button
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Workbooks(CWName).Worksheets("Premium Comparison").Protect "Racers"
Exit Sub
End Sub

我们还没有全部升级，所以我仍然需要 2010 用户才能导出/保存，但也允许 2016 用户这样做。目前他们只是收到 Invalid excel version 消息。

Answer 1

未经测试仅供参考，但我会使用 Case X To Y 组合您相同的“案例陈述”，并将 15 增加到 16，等于 Office 2016。

来源：

https://www.ozgrid.com/VBA/select-case.htm

https://www.rondebruin.nl/win/s9/win012.htm

代码：

Private Sub SaveIt(SaveName As String)
Dim Fullname As String
Dim FileName As String
Dim Result As String
On Error GoTo ErrHandler

SaveName = SaveName & "\Premium Comparison"
Select Case Int(Application.Version)
  Case 11 ' Office 2003
   Application.Dialogs(xlDialogSaveAs).Show arg1:=SaveName ', arg2:=56, no arg2 is used in 2003,arg2 is to save 2003 in excel 2010
  Case 14 to 16 ' Office 2010 --> Office 2016
   Application.DisplayAlerts = False
   Result = Application.Dialogs(xlDialogSaveAs).Show(arg1:=SaveName, arg2:=51)   'xlsx format in 2010
   If Result Then
    Fullname = ActiveWorkbook.Fullname
    FileName = ActiveWorkbook.Name
    Application.Workbooks(FileName).Close SaveChanges:=False
    Application.Workbooks.Open FileName:=Fullname, UpdateLinks:=False
    Application.DisplayAlerts = True
   Else
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
   End If
  Case Else
   MsgBox "Invalid excel version - " & Application.Version
End Select
Workbooks(CWName).Worksheets("Premium Comparison").Protect "Racers"
Exit Sub
ErrHandler:
'User pressed the Cancel button
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Workbooks(CWName).Worksheets("Premium Comparison").Protect "Racers"
Exit Sub
End Sub