Protect an array of sheets

[Lost Paul]

I'm trying to add protection to an array of named tabs in one go, but am struggling.
Is this doable?

[HansV]

As you have found, that is not possible.
You might use a macro to protect multiple sheets in a loop:

Code: Select all

Sub ProtectSheets()
    Dim wsh As Worksheet
    For Each wsh In Worksheets(Array("Sheet1", "Sheet2", "Sheet4"))
        wsh.Protect Password:="Secret"
    Next wsh
End Sub

[Lost Paul]

Perfect!

Thank you

[Lost Paul]

As an extension of this, I have been tasked with copying data from a pivot table (changing the filter) to individual tabs.
Not what I would recommend, but there you go.

Here's what I have so far & can anyone help getting this to work please?

TIA

Code: Select all

Sub WIPupdate()

    Dim Tws As Worksheet
    Dim Chk As Integer
    Dim Rec As Integer
    Dim WshS As Worksheet
    Dim TgtRw As Integer
    Dim TwsR As String
    
        
    Set WshS = Worksheets("Pivots")
    
    For Each Tws In Worksheets(Array("Bedford", "Belvedere", "Bristol"))
    
        'Change filters on pivots
         Sheets("Pivots").Select
        'Set TwsR = Tws
        ActiveWorkbook.RefreshAll
        ActiveSheet.PivotTables("PivotTable2").PivotFields("Contracted Location"). _
            ClearAllFilters
        ActiveSheet.PivotTables("PivotTable2").PivotFields("Contracted Location"). _
            CurrentPage = TwsR
            
        Range("B8").Select
        ActiveSheet.PivotTables("PivotTable1").PivotFields("Loc").ClearAllFilters
        ActiveSheet.PivotTables("PivotTable1").PivotFields("Loc").CurrentPage = _
            TwsR
        
        'Check if blank & row count
        TgtRw = WshS.Range("D2")
        Chk = WshS.Range("A2")
        Rec = Chk
        If Chk > 0 Then
                'copy data to defined location tab
                Range(Cells(8, "B"), Cells(Rec + TgtCell, "C")).Copy
                Sheets(TwsR).Select
                Selection.PasteSpecial Paste:=xlPasteValues
                Range("D5").Select
        End If

    Next Tws
    
    End Sub

[Lost Paul]

Sorted! :)

Here's what I ended up with;

Code: Select all

Sub UpdateTabs()

    Dim Tws As Worksheet
    Dim Chk As Integer
    Dim Rec As Integer
    Dim WshS As Worksheet
    Dim TgtRw As Integer
    Dim TwsR As String
    Dim TgtCell As Integer

    Set WshS = Worksheets("Pivots")

    For Each Tws In Worksheets(Array("Bedford", "Belvedere", "Bristol", "Buckingham", "Burgess Hill", _
        "Colchester", "Croydon", "Eastleigh", "Exeter", "Greenford", "New Southgate", _
        "Peterborough", "Sittingbourne", "Watton", "Woking"))
        
        ' Get the name of the current worksheet
        TwsR = Tws.Name

        ' Change filters on pivots
        Sheets("Pivots").Select
        ActiveWorkbook.RefreshAll
        ActiveSheet.PivotTables("PivotTable2").PivotFields("Contracted Location").ClearAllFilters
        ActiveSheet.PivotTables("PivotTable2").PivotFields("Contracted Location").CurrentPage = TwsR

        ActiveSheet.PivotTables("PivotTable1").PivotFields("Loc").ClearAllFilters
        ActiveSheet.PivotTables("PivotTable1").PivotFields("Loc").CurrentPage = TwsR

        ' Check if blank & row count
        TgtRw = WshS.Range("D2").Value
        Chk = WshS.Range("D2").Value
        Rec = Chk

        If Chk > 0 Then
            ' Copy data to defined location tab
            TgtCell = 8 ' Assuming data starts from row 8
            Range(Cells(TgtCell, "B"), Cells(Rec + TgtCell - 1, "C")).Copy
            Sheets(TwsR).Select
            Range("b5").PasteSpecial Paste:=xlPasteValues ' Adjust the destination as needed
            Application.CutCopyMode = False
        End If
    Next Tws

End Sub