使用VBA和按钮将单个工作表导出到新工作簿 [英] Export a single worksheet to a new workbook using VBA and a button

问题描述

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

在升级到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年的用户才能进行导出/保存.目前，他们只是收到无效的excel版本消息.

解决方案

仅对FYI进行了测试，但我将使用Case X To Y并将15至16递增(等于Office 2016)来组合相同的"Case Statements".

来源:

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

I have a worksheet that has a button, once clicked it will export that sheet into a new workbook and allow the user to save the new workbook to their specified location.

Before upgrading to excel 2016 this code worked fine, but now it's hitting my error handler. I am fairly new to VBA and did not create this code to begin with, so I am not sure if there is an easier way or if I just need to enter a new case for 2016 users and what that new code should say.

Here is the current code:

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

We haven't all been upgraded yet, so I still need 2010 users to be able to export/save but also allow 2016 users to do so. Currently they are just getting the Invalid excel version message.

解决方案

Untested just FYI, but I would combine your identical "Case Statements" by using Case X To Y and increment 15 to 16 which equals Office 2016.

Sources:

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

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

Code:

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

这篇关于使用VBA和按钮将单个工作表导出到新工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！