ExcelBanter - View Single Post

deutz

Hi and thanks in advance,

I have a workbook with a protected sheet. I run some code that Saves As into a new workbook and then removes all formulas leaving the values and formats in tact. I would like to leave the sheet in the original wkb protected but remove the protection from the sheet in the Saved As wkb as part of this process? Not sure how or where to slot in the unprotect code?

Here is my code thus far:

Code:

Sub ExportWorkbook()
   Dim varFileName As Variant
   Dim strRestrictedName As String

   On Error GoTo Err_Handler

   strRestrictedName = ActiveWorkbook.Name

   Application.EnableEvents = False
   varFileName = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path & "\", fileFilter:="Microsoft Office Excel Workbook (*.xls), *.xls")
   varFileName = Mid$(varFileName, InStrRev(varFileName, "\") + 1)

   If varFileName < False Then
      If UCase$(varFileName) < UCase$(strRestrictedName) Then
          ActiveWorkbook.SaveAs varFileName
          Application.EnableEvents = True
          FormulasToValues (varFileName)
          ActiveWorkbook.Save
          MsgBox "Done"
      Else
          MsgBox "Invalid File Name", vbCritical, "Stop"
      End If
   Else
       ' Cancelled Save As dialog
   End If
   Application.EnableEvents = True

Err_Exit:
   Application.EnableEvents = True
   Exit Sub
Err_Handler:
   Select Case Err
       Case 1004 ' Cancelled overwrite of existing file in Save As msgbox
           ' do nothing
       Case Else
           MsgBox Err & " " & Err.Description
   End Select
   GoTo Err_Exit
End Sub

Sub FormulasToValues(WkbName As String)
   Dim ws As Worksheet
   Dim wkb As Workbook

   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual

   Set wkb = Application.Workbooks(WkbName)
 For Each ws In wkb.Worksheets
       With ws
           .Activate
           On Error Resume Next
           .ShowAllData
           .AutoFilterMode = False
           Worksheets(ws).ShowAllData = True
           On Error GoTo 0
           .Cells.Select
            Selection.Copy
            Selection.PasteSpecial xlPasteValuesAndNumberFormats
            Selection.PasteSpecial xlFormats
            Selection.PasteSpecial xlPasteColumnWidths
       End With
       ws.Range("A1").Select
       Application.CutCopyMode = False
   Next
   Sheets(1).Activate

   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub