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

chrono2483

Board Regular
Joined
Aug 23, 2014
Messages
164
Office Version
  1. 2016
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:

Code:
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.
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Try this:

Code:
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
 
Upvote 0
Try this:

Code:
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!
 
Upvote 0
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.
 
Upvote 0
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!
 
Upvote 0
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.


Code:
       '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.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top