SaveShtsAsBook and retain sheet protection

[NaomiB]

Hi
I run the SaveShtsAsBook macro below to separate a worksheets into individual workbooks in order to send reports to multiple customers. My problem is that I generate the worksheets from a pivot table filtered by customer reference number. It has occurred to me that even after separating the worksheets the pivot table filters are still 'live'

In order to keep confidentiality I need to do one of two things:

Lock the pages and keep them locked after running SaveShtsAsBook
Or get the macro to lock the workbooks when I run SaveShtsAsBook

I've tried locking all pages and then running SaveShtsAsBook but the individual workbooks are unlocked after macro is run defeating the process. I'm no tech wizard and just found this on the internet but it works fine except the filters still showing.

This is my macro:

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs FileName:=MyFilePath _
& "\" & SheetName & ".xlsx"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub

 

[sijpie]

Welcome to the board NaomiB,

If you leave the source for the pivot table intact (even if sheet protected) the data is not secure. It is pretty easy to disable the protection.

If you want to send the client just a small set of data (shown in the pivot table) .

You will have to copy the results part of the pivot table and then paste as values. Then apply the formatting.

By the way, next time you paste code, do it between VBA code tags: in your post window you will see formatting icons. Click on the green one saying VBA. Then paste your code where the cursor is. like :

Option Explicit

Sub SaveShtsAsBook()
    Dim ShtSource As Worksheet, SheetName$, MyFilePath$, N&
    Dim wbWB As Workbook
    Dim rInp As Range
    Dim sSep As String, iC As Integer
   
    MyFilePath$ = ActiveWorkbook.Path
   
   
    'set system separator
    sSep = IIf(MyFilePath Like "*\*", "\", "/")
    'make directory with same name as thiswrokbook (extension removed)
    MyFilePath = MyFilePath & sSep & _
        Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        ' End With
        On Error Resume Next '<< check if a folder exists
        MkDir MyFilePath '<< create a folder
        On Error GoTo 0     '>>>> ALWAYS reset error behaviour to normal when 'resume' no longer needed
        For N = 1 To ThisWorkbook.Sheets.Count
            ' Sheets(N).Activate no need to activate the sheets. It works faster without
            Set ShtSource = ThisWorkbook.Sheets(N)
            Set wbWB = Workbooks.Add(xlWBATWorksheet)
            'copy the sheet to the new workbook to get the formatting across
            ShtSource.Copy before:=wbWB.Sheets(1)
            With wbWB
                ' remove any blank sheets
                For iC = 2 To .Sheets.Count
                    .Sheets(iC).Delete
                Next iC
                With .ActiveSheet
                    'set the name of the sheet
                    .Name = ShtSource.Name
                    'now delete the contents as these contain the pivot table data
                    .Cells.ClearContents
                    'and now recopy but only the values, so no hidden values
                    'by not using "copy/pastespecial" but just setting the values it is very fast
                    Set rInp = ShtSource.UsedRange
                    .Range(Cells(1, 1), Cells(rInp.Rows.Count, rInp.Columns.Count)).Value = rInp.Value
                   
                    'Now format the dataranges as table
                    Dim ptPT As PivotTable

                    For Each ptPT In ShtSource.PivotTables
                        .ListObjects.Add(xlSrcRange, Range(GetPivotTRange(ptPT).CurrentRegion.Address), , xlYes).Name = _
                            ptPT.Name
                        .ListObjects(ptPT.Name).TableStyle = "TableStyleMedium2"
                    Next ptPT

                End With
                'save book in this folder
                .SaveAs Filename:=MyFilePath _
                & sSep & ShtSource.Name & ".xlsx"
                .Close SaveChanges:=True
            End With
        Next
    End With
    MsgBox "Done"
End Sub

Function GetPivotTRange(ptPT As PivotTable) As Range
    Set GetPivotTRange = ptPT.DataBodyRange.CurrentRegion
End Function