Экспорт одного листа в новую книгу с использованием VBA и кнопки - PullRequest
Новая
       28

Экспорт одного листа в новую книгу с использованием VBA и кнопки

1 голос
/ 30 мая 2019

У меня есть лист, на котором есть кнопка, после щелчка он экспортирует этот лист в новую книгу и позволит пользователю сохранить новую книгу в указанном месте.

До обновления до 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.

1 Ответ

0 голосов
/ 31 мая 2019

Не проверено только на ваше усмотрение, но я бы скомбинировал ваши идентичные "Заявления о делах", используя 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
...