Protected Worksheet, Unprotect and Re-protect (Part 2)

[chrono2483]

Good Afternoon Team,

I've posed this question before, and have tried the solutions - however I keep running into an error partway through my code (in the most odd place). Hoping by posting the code - it may help with identifying where the problem is, as well as a possible solution.

Default state = protected worksheet, except for the following, which I want the user to always be able to edit:
1) Cell I2, on tab 'Home & Garden'
2) 'Paste Here' tab
Once the Macro is enabled = unprotect everything, so that the macro can copy/paste, etc as designed.
Once the Macro is complete = lock everything except for the aforementioned #1 and #2.

This is the code I have:

Sub SiteCleanUp()
'
' SiteCleanUp Macro
'
' Keyboard Shortcut: Ctrl+j
'

Dim i As Long
Dim l As Long

    ' Prevents screen refreshing.
    Application.ScreenUpdating = False

' On Error GoTo 2

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
'Copy data just as is into new tab to store
    Cells.Select
    Selection.Copy
    Sheets("Hidden Site").Visible = True
    Sheets("Hidden Site").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Hidden Site").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Paste Here").Select
    

'Unmerge all cells
    Range("A1").Select
        With ActiveSheet
            Cells.UnMerge
        End With

'Remove header rows
    Rows("1:4").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    
'first run to clean columns
    Columns("A:B").Select
    Selection.Delete Shift:=xlUp
    Columns("B:B").Select
    Selection.Delete Shift:=xlUp
    Columns("C:C").Select
    Selection.Delete Shift:=xlUp
    Columns("F:F").Select
    Selection.Delete Shift:=xlUp
    Columns("G:G").Select
    Selection.Delete Shift:=xlUp
    Columns("H:I").Select
    Selection.Delete Shift:=xlUp
    Columns("I:L").Select
    Selection.Delete Shift:=xlUp
    Columns("J:N").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select

'delete all blank rows
'    Application.CutCopyMode = False
    With ActiveSheet
        Rows("1:13000").Select
            For i = Selection.Rows.Count To 1 Step -1
                If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
            Selection.Rows(i).EntireRow.Delete
        End If
        Next i
    End With

'find "Report Data" (where data starts to repeat - delete all rows after
    Dim LastRow As Long, myCell As Range, myRange As Range
    Dim myCell1 As Range
 
    LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row 'find last row
    Set myCell1 = Range("A" & LastRow)
    Cells.Find(What:="Report Data", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False).Activate
    Set myCell = ActiveCell
 
    Set myRange = Range(myCell, myCell1) 'select from last row to current row selected
    myRange.EntireRow.Delete Shift:=xlUp 'delete
' Selection.Delete Shift:=xlUp

'paste data into Working worksheet
   Sheets("Working").Select
    Columns("A:I").Select
    Selection.ClearContents
   
    Sheets("Paste Here").Select
    Range("A3:I" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Working").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    Columns("A:I").EntireColumn.AutoFit
    Range("C1").Select
    Selection.Copy
    Columns("C:C").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "[h]:mm"
   Sheets("Paste Here").Select
    Range("A1").Select

'find "Available" and delete rows
    Dim SrchRng
     
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Available", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing
    
        Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Out", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("After", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Call", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Hold", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Consult", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Inbound", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Personal", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Conference", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Help", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Activities", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Personal", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Task", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Duties", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Total", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Follow Up", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Follow Up", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Face to Face", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing
    
'autofit
    Columns("A:I").EntireColumn.AutoFit
    
'paste data into Data worksheet
   
Sheets("Data").Select
    Columns("A:I").Select
    Selection.ClearContents
    
    Sheets("Paste Here").Select
    Range("A3:I" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    
'autofit Data worksheet
    Columns("A:I").EntireColumn.AutoFit

'clear M column before pasting

Range("m:n").Clear
Range("EL:JJ").Clear

'copy and paste agent

 Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
 Set myCell = SrchRng.Find("Rep", LookIn:=xlValues)
 If Not myCell Is Nothing Then
 firstAddress = myCell.Address
 i = 3
 myCell.Copy Cells(i, "M")
 Else
 MsgBox "Can't find search string"
 Exit Sub
 End If
 Do
 Set myCell = SrchRng.FindNext(myCell)
 If myCell Is Nothing Then Exit Do
 If myCell.Address = firstAddress Then Exit Do
 i = i + 1
 myCell.Copy Cells(i, "M")
 Loop
  
'copy and paste date

  Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
 Set myCell = SrchRng.Find("Date", LookIn:=xlValues)
 If Not myCell Is Nothing Then
 firstAddress = myCell.Address
 i = 3
 myCell.Copy Cells(i, "N")
 Else
 MsgBox "Can't find search string"
 Exit Sub
 End If
 Do
 Set myCell = SrchRng.FindNext(myCell)
 If myCell Is Nothing Then Exit Do
 If myCell.Address = firstAddress Then Exit Do
 i = i + 1
 myCell.Copy Cells(i, "N")
 Loop
    
    'row to column of agents
    
    Dim iLRow, iStart, iEnd, iCol As Integer

iLRow = Cells(Cells.Rows.Count, 2).End(xlUp).Row
iStart = 1
iEnd = 2
iCol = 142

Do While iEnd <= iLRow + 1
    If Left(Cells(iStart, 1), 5) <> "Rep" Then
        iStart = iStart + 1
        iEnd = iStart + 1
    Else
        If Left(Cells(iEnd, 1), 5) <> "Rep" And iEnd <> iLRow + 1 Then
            iEnd = iEnd + 1
        Else
            Range(Cells(iStart, 1), Cells(iEnd - 1, 9)).Copy
            Cells(1, iCol).PasteSpecial xlPasteAll
            'Range(Cells(iStart, 1), Cells(iEnd - 1, 9)).Clear
            iStart = iEnd
            iEnd = iStart + 1
            iCol = iCol + 9
        End If
    End If
Loop

Application.CutCopyMode = False
    
   
 
    'go back to summary page
 Sheets("What you need").Select
    Range("A1").Select 'go back to summary page
    
 'turn back on updating, auto calculation
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
   
       'Autosave
FName = "C:\Users\" & VBA.Environ("Username") & "\Desktop\Outdoor Tool\" & Format(Range("BB7"), "mmmm-dd-yyyy") & ".xlsm"
    ActiveWorkbook.SaveAs Filename:=FName, _
                          FileFormat:=xlOpenXMLWorkbookMacroEnabled
     Sheets("Data").Select
     Sheets("What you need").Select
    Range("A3").Select
   
End

2
        With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
    MsgBox "Error"
  
    ' Enables screen refreshing.
    Application.ScreenUpdating = True
   
'Autosave
FName = "C:\Users\" & VBA.Environ("Username") & "\Documents\Outdoor Tool\" & Format(Range("A3"), "mmm-d-yyyy") & ".xlsm"
    ActiveWorkbook.SaveAs Filename:=FName, _
                          FileFormat:=xlOpenXMLWorkbookMacroEnabled
   
   
End Sub

Thank you.

 

[V_Malkoti]

Try this:

Sub SiteCleanUp()
    Dim sh As Worksheet
    Dim strPass As String
    
    strPass = "pass"
    ' Macro started - unlock sheets
    For Each sh In ThisWorkbook.Worksheets
        sh.Unprotect Password:=strPass
    Next
    
    
    ''' -------
    ''' Existing code here
    ''' -------
    
    ' Macro finished - lock sheets
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Paste Here" Then ' Don't lock this one
            sh.Cells.Locked = True ' Lock all cells
            If sh.Name = "Home & Garden" Then sh.Range("I2").Locked = False ' Leave cell I2 unlocked
            sh.Protect Password:=strPass, UserInterfaceOnly:=True ' Lock the sheet
        End If
    Next
    
    ''' -------
    ''' Cleanup/Error handling here
    ''' -------
    
End Sub

 

[chrono2483]

Try this:

Sub SiteCleanUp()
    Dim sh As Worksheet
    Dim strPass As String
    
    strPass = "pass"
    ' Macro started - unlock sheets
    For Each sh In ThisWorkbook.Worksheets
        sh.Unprotect Password:=strPass
    Next
    
    
    ''' -------
    ''' Existing code here
    ''' -------
    
    ' Macro finished - lock sheets
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Paste Here" Then ' Don't lock this one
            sh.Cells.Locked = True ' Lock all cells
            If sh.Name = "Home & Garden" Then sh.Range("I2").Locked = False ' Leave cell I2 unlocked
            sh.Protect Password:=strPass, UserInterfaceOnly:=True ' Lock the sheet
        End If
    Next
    
    ''' -------
    ''' Cleanup/Error handling here
    ''' -------
    
End Sub

Thanks V_Malkoti - the above code seems to be able to unlock everything to run the script, however once complete it doesn't lock the spreadsheet. I pasted my code in the "existing code here" section. Am I missing something? What am I to do with the "Cleanup/Error handling here"? Thanks!

 

[V_Malkoti]

This code should lock everything (except sheet named "Paste Here" and cell I2 of "Home & Garden") after your existing code is run. Locking all cells and sheets is done in the second For-each loop of the code. Which sheets do you still see left unlocked? Can you place a breakpoint at the beginning of this second loop and see if it is getting executed after your existing code block is executed?

The cleanup/error handling part is optional. You can write your error handling block there if you decide to use on error goto construct in your code.

 

[chrono2483]

This code should lock everything (except sheet named "Paste Here" and cell I2 of "Home & Garden") after your existing code is run. Locking all cells and sheets is done in the second For-each loop of the code. Which sheets do you still see left unlocked? Can you place a breakpoint at the beginning of this second loop and see if it is getting executed after your existing code block is executed?

The cleanup/error handling part is optional. You can write your error handling block there if you decide to use on error goto construct in your code.

I start with everything locked, and run the macro. It has no problem unlocking everything - however the 2nd part doesn't seem to re-lock anything. All tabs within the worksheet are unlocked. I tried placing a breakpoint at the 2nd For-each code, but didn't seem to accomplish anything?

Any possible suggestion/solution?

Thanks!

 

[V_Malkoti]

You have an End statement right after autosave block in your code, which will terminate code execution. Since locking part is after the End statement, it never gets executed. I don't think you really need that statement, so just comment it.

       'Autosave
fName = "C:\Users\" & VBA.Environ("Username") & "\Desktop\Outdoor Tool\" & Format(Range("BB7"), "mmmm-dd-yyyy") & ".xlsm"
    ActiveWorkbook.SaveAs Filename:=fName, _
                          FileFormat:=xlOpenXMLWorkbookMacroEnabled
     Sheets("Data").Select
     Sheets("What you need").Select
    Range("A3").Select
   
[B][COLOR=#ff0000]End[/COLOR][/B]


[COLOR=#0000ff][B]2[/B][/COLOR]
        With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
    MsgBox "Error"

Also I'm not sure what "2" is doing there in your code. Also code blocks after 2 seems redundant. So just comment that part out too.