Создание новой книги из шаблона, существующего в текущей книге

Question

Вот что мне нужно, чтобы сохранить любой шаблон, называемый в ComboBox, в виде отдельной книги без какого-либо макроса в новом, но с сохранением формул с внутренними ссылками , отдых должен быть преобразован в значения.

Слушайте, это моя попытка сделать это, что явно не сработало, поскольку оно сохраняет активный лист, а не шаблон, который выбран. также из-за проверки, что необходимо, я вынужден дважды использовать часть кода, есть ли способ сделать это любым другим способом.

Думаю, мне также нужно упомянуть, что ComboBox находится на UserForm.

Пожалуйста, помогите мне

'Continue to create your invoice and check for the archive folder existance 
Private Sub ContinueButton_Click() 
    If cmbSheet.Value = "" Then 
    MsgBox "Please select the Invoice Template from the list to continue." 
    ElseIf cmbSheet.Value <> 0 Then 
    Dim response 
    Application.ScreenUpdating = 0 
    Sheets(cmbSheet.Value).Visible = True 
'Creating the directory only if it doesn't exist 
    directoryPath = getDirectoryPath 
    If Dir(directoryPath, vbDirectory) = "" Then 
     response = MsgBox("The directory " & Settings.Range("_archiveDir").Value & " does not exist. Would you like to create it?", vbYesNo) 
     If response = vbYes Then 
      createDirectory directoryPath 
      MsgBox "The folder has been created. " & directoryPath 




      'Application.Goto Sheets(cmbSheet.Value).[a22], True 
      Application.ScreenUpdating = False 
     Else 
      MsgBox "You need to create new folder " & Settings.Range("_archiveDir").Value & " to archive your invoices prior to creating them." 
      Unload Me 
     End If 
     Unload Me 
    ElseIf Dir(directoryPath, vbDirectory) <> directoryPath Then 

     'Working in Excel 97-2007 
    Dim FileExtStr As String 
    Dim FileFormatNum As Long 
    Dim Sourcewb As Workbook 
    Dim Destwb As Workbook 
    Dim TempFilePath As String 
    Dim TempFileName As String 
    Dim newFile As String, fName As String 
    Dim sep As String 
    sep = Application.PathSeparator 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    Set Sourcewb = ActiveWorkbook 

    'Copy the sheet to a new workbook 
    ActiveSheet.Copy 
    Set Destwb = ActiveWorkbook 

    'Determine the Excel version and file extension/format 
    With Destwb 
     If Val(Application.Version) < 12 Then 
      'You use Excel 97-2003 
      FileExtStr = ".xls": FileFormatNum = -4143 
     Else 
      'You use Excel 2007 
      'We exit the sub when your answer is NO in the security dialog that you 
      'only see when you copy a sheet from a xlsm file with macro's disabled. 
      If Sourcewb.Name = .Name Then 
       With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
       End With 
       MsgBox "Your answer is NO in the security dialog" 
       Exit Sub 
      Else 
       Select Case Sourcewb.FileFormat 
       Case 51: FileExtStr = ".xlsx": FileFormatNum = 56 
       Case 52: 
        If .HasVBProject Then 
         FileExtStr = ".xlsm": FileFormatNum = 56 
        Else 
         FileExtStr = ".xlsx": FileFormatNum = 56 
        End If 
       Case 56: FileExtStr = ".xls": FileFormatNum = 56 
       Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 
       End Select 
      End If 
     End If 
    End With 

    ' 'If you want to change all cells in the worksheet to values, uncomment these lines. 
    ' With Destwb.Sheets(1).UsedRange 
    '  .Cells.Copy 
    '  .Cells.PasteSpecial xlPasteValues 
    '  .Cells(1).Select 
    ' End With 
    ' Application.CutCopyMode = False 

    'Save the new workbook and close it 
    fName = Range("I11").Value 
    'Change the date format to whatever you'd like, but make sure it's in quotes 
    newFile = fName & " " & Format$(Date, "mm-dd-yyyy") & Columns("M:N").Select 
    Selection.Delete Shift:=xlToLeft 
    TempFilePath = directoryPath & sep 
    TempFileName = "New File" 

    With Destwb 
     .SaveAs TempFilePath & TempFileName, FileFormat:=FileFormatNum 
     .Close SaveChanges:=False 
    End With 

    MsgBox "You can find the new file in " & TempFilePath 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 


     'Application.Goto Sheets(cmbSheet.Value).[a22], True 
     Application.ScreenUpdating = False 
     Unload Me 
    End If 
    End If 
End Sub 

Answer 1

Как это шаблон лист, который вы хотите скопировать, вы, вероятно, хотите сделать Sourcewb.Sheets(cmbSheet.Value).Copy вместо ActiveSheet.Copy.

Чтобы избежать выполнения кода дважды, измените этот код:

Else 
     MsgBox "You need to create new folder " & Settings.Range("_archiveDir").Value & " to archive your invoices prior to creating them." 
     Unload Me 
    End If 
    Unload Me 
ElseIf Dir(directoryPath, vbDirectory) <> directoryPath Then 

на это вместо:

Else 
     MsgBox "You need to create new folder " & Settings.Range("_archiveDir").Value & " to archive your invoices prior to creating them." 
     Unload Me 
    End If 
End If 
If Dir(directoryPath, vbDirectory) <> directoryPath Then 

Вот весь код после моих изменений

Option Explicit 

'Continue to create your invoice and check for the archive folder existance 
Private Sub ContinueButton_Click() 

    If cmbsheet.Value = "" Then 
     MsgBox "Please select the Invoice Template from the list to continue." 
    ElseIf cmbsheet.Value <> 0 Then 
     Dim response 
     Application.ScreenUpdating = 0 
     'Creating the directory only if it doesn't exist 
     directoryPath = getDirectoryPath 
     If Dir(directoryPath, vbDirectory) = "" Then 
      response = MsgBox("The directory " & Settings.Range("_archiveDir").Value & " does not exist. Would you like to create it?", vbYesNo) 
      If response = vbYes Then 
       createDirectory directoryPath 
       MsgBox "The folder has been created. " & directoryPath 

       'Application.Goto Sheets(cmbSheet.Value).[a22], True 
       Application.ScreenUpdating = False 
      Else 
       MsgBox "You need to create new folder " & Settings.Range("_archiveDir").Value & " to archive your invoices prior to creating them." 
       'Unload Me 
       GoTo THE_END 
      End If 
     End If 
     If Dir(directoryPath, vbDirectory) <> directoryPath Then 
      Sheets(cmbsheet.Value).Visible = True 

       'Working in Excel 97-2007 
      Dim FileExtStr As String 
      Dim FileFormatNum As Long 
      Dim Sourcewb As Workbook 
      Dim Destwb As Workbook 
      Dim TempFilePath As String 
      Dim TempFileName As String 
      Dim newFile As String, fName As String 
      Dim sep As String 
      sep = Application.PathSeparator 

      With Application 
       .ScreenUpdating = False 
       .EnableEvents = False 
      End With 

      Set Sourcewb = ActiveWorkbook 

      'Copy the sheet to a new workbook 
      Sourcewb.Sheets(cmbsheet.Value).Copy 
      Set Destwb = ActiveWorkbook 

      'Determine the Excel version and file extension/format 
      With Destwb 
       If Val(Application.Version) < 12 Then 
        'You use Excel 97-2003 
        FileExtStr = ".xls": FileFormatNum = -4143 
       Else 
        'You use Excel 2007 
        'We exit the sub when your answer is NO in the security dialog that you 
        'only see when you copy a sheet from a xlsm file with macro's disabled. 
        If Sourcewb.Name = .Name Then 
         'With Application 
         ' .ScreenUpdating = True 
         ' .EnableEvents = True 
         'End With 
         MsgBox "Your answer is NO in the security dialog" 
         'Exit Sub 
         GoTo THE_END 
        Else 
         Select Case Sourcewb.FileFormat 
         Case 51: FileExtStr = ".xlsx": FileFormatNum = 56 
         Case 52: 
          If .HasVBProject Then 
           FileExtStr = ".xlsm": FileFormatNum = 56 
          Else 
           FileExtStr = ".xlsx": FileFormatNum = 56 
          End If 
         Case 56: FileExtStr = ".xls": FileFormatNum = 56 
         Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 
         End Select 
        End If 
       End If 
      End With 

      'If you want to change all cells in the worksheet to values, uncomment these lines. 
      'With Destwb.Sheets(1).UsedRange 
      With Sourcewb.Sheets(cmbsheet.Value).UsedRange 
       .Cells.Copy 
       .Cells.PasteSpecial xlPasteValues 
       .Cells(1).Select 
      End With 
      Application.CutCopyMode = False 

      'Save the new workbook and close it 
      fName = Range("I11").Value 
      'Change the date format to whatever you'd like, but make sure it's in quotes 
      newFile = fName & " " & Format$(Date, "mm-dd-yyyy") & Columns("M:N").Select 
      Selection.Delete Shift:=xlToLeft 
      TempFilePath = directoryPath & sep 
      TempFileName = "New File" 

      With Destwb 
       .SaveAs TempFilePath & TempFileName, FileFormat:=FileFormatNum 
       .Close SaveChanges:=False 
      End With 

      MsgBox "You can find the new file in " & TempFilePath 

      'With Application 
      ' .ScreenUpdating = True 
      ' .EnableEvents = True 
      'End With 


      'Application.Goto Sheets(cmbSheet.Value).[a22], True 
      'Application.ScreenUpdating = False 
      'Unload Me 
     End If 
    End If 

THE_END: 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
    Unload Me 


End Sub