Page Protecting Itself After Everychange

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
4,564
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I'm hoping someone will be kind enough to help me isolate and resolve a problem I am having with my VBA application.

My worksheet GUI_1 (aka ws_gui1) for some reason protects itself everytime I make a change to it.

So, if I have code in a module like this:
VBA Code:
Sub test
With ws_gui1
.unprotect '(I know the worksheet will be protected)
.cells(1,1) = "This cell will update without error because the worksheet is unprotected."
.cells(2,1) = "This will result in an error because the worksheet has been protected."
End With
End Sub

Here is my worksheet (ws_gui1) change code. I suspect the cause resides in it, but with all my manually stepping through, I can't isolate it. ANy help will be greatly appreciated.

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    'Stop
    Dim fmr_month As String
    Dim rng_ta As Range
    Dim cn As Integer
    Dim xz As String, trc_text As String
    Dim rng_sstart As Range
    Dim tgt_r As Double
    
    If Not mbevents Then Exit Sub
    
    With ws_gui1
        Set rng_sstart = .Range("BD4:BD" & .Cells(.Rows.Count, "BD").End(xlUp).Row)
        Set rng_role = .Range("AZ4:AZ" & .Cells(.Rows.Count, "AZ").End(xlUp).Row)
    
        '----  DATE ENTRY CHANGES  -----------------------------------------------------------------------------
        
        'YEAR
        If Target.Address = "$D$2" Then
        
        'ERROR CHECKS
        'if year entered is text
            If IsNumeric(.Range("D2")) = False Then
                MsgBox "Please enter a valid year. [>2019]", vbCritical, "INVALID YEAR"
                mbevents = False
                .Range("D2") = td_yr
                .Unprotect
                n_date = DateSerial(td_yr, td_month, td_day)
                .Protect
                mbevents = True
                Exit Sub
            End If
        
            'if year is post season
            pyear = Format(DateAdd("yyyy", -1, td_date), "yyyy")
            If .Range("D2") < CInt(pyear) Then
                MsgBox "Please enter a valid year. [>" & pyear & "]", vbCritical, "INVALID YEAR"
                mbevents = False
                .Range("D2") = td_yr
                .Unprotect
                n_date = DateSerial(td_yr, td_month, td_day)
                .Protect
                mbevents = True
                Exit Sub
            End If
        
            'if year exceeds 4 digits
            If .Range("d2") > 9999 Then
                MsgBox "Please enter a valid year. [<9999]", vbCritical, "INVALID YEAR"
                mbevents = False
                .Range("d2") = td_yr
                .Unprotect
                n_date = DateSerial(td_yr, td_month, td_day)
                .Protect
                mbevents = True
                Exit Sub
            End If
        
            td_yr = .Range("D2")
            n_date = DateSerial(td_yr, td_month, td_day)
            mbevents = False
            .Unprotect
            .Range("G2") = Format(n_date, "ddd")
            .Protect
            mbevents = True
        
            'leap year
            Leap_Year 'use to determine number of days
            Month_Validation
        
        End If
        
        'DAY
        If Target.Address = "$F$2" Then
        'Stop
        'MsgBox "Day change"
            td_day = .Range("F2")
            n_date = DateSerial(td_yr, td_month, td_day)
            mbevents = False
            .Unprotect
            .Range("G2") = UCase(Format(n_date, "ddd"))
            .Protect
            mbevents = True
        End If
        
        'MONTH
        If Target.Address = "$E$2" Then
        'MsgBox "Month change"
            fmr_month = MonthName(td_month)
            txt_month = .Range("E2")
            td_month = Month(DateValue("01-" & txt_month & "-1900"))
            n_date = DateSerial(td_yr, td_month, td_day)
            
            'day conflict
            mbevents = False
            'determine appropropriate day lists
            If td_month = 2 Then 'in a leap year February has 29 days
                If usr_lp_yr = True Then
                    If td_day > 29 Then 'error
                        MsgBox "Please adjust the day before adjusting the month." & Chr(10) & txt_month & " only has 29 days.", vbCritical, "DATE CONFLICT"
                        .Range("E2") = UCase(fmr_month)
                        .Range("F2") = td_day
                        mbevents = True
                        Exit Sub
                    End If
                Else 'not a leap year
                    MsgBox "Please adjust the day before adjusting the month." & Chr(10) & txt_month & " only has 28 days.", vbCritical, "DATE CONFLICT"
                    .Range("E2") = UCase(fmr_month)
                    .Range("F2") = tm_day
                    mbevents = True
                    Exit Sub
                End If
            End If
        
            If td_month = 4 Or tm_month = 6 Or tm_month = 9 Or tm_month = 11 Then
                If td_day > 30 Then 'error
                    MsgBox "Please adjust the day before adjusting the month." & Chr(10) & txt_month & " only has 30 days.", vbCritical, "DATE CONFLICT"
                    .Range("E2") = UCase(fmr_month)
                    .Range("F2") = tm_day
                    mbevents = True
                    Exit Sub
                End If
            End If
            
            mbevents = False
            .Unprotect
            .Range("G2") = Format(n_date, "ddd")
            .Protect
            mbevents = True
        
            'with month change comes day range change
            Month_Validation
        
            mbevents = True
        End If
        If Not Intersect(Target, rng_role) Is Nothing Then 'CHANGE in staff start
            tgt_r = .Range(Target.Address).Row
            MsgBox "Staff Roll - Row: " & tgt_r '& Chr(13) & "   - Check for valid time value." & Chr(13) & "   - Check against end time."
            mbevents = True
            Stop
            chgrole tgt_r
        End If
        If Not Intersect(Target, rng_sstart) Is Nothing Then 'CHANGE in staff start
            tgt_r = .Range(Target.Address).Row
            MsgBox "Staff Start - Row: " & tgt_r & Chr(13) & "   - Check for valid time value." & Chr(13) & "   - Check against end time."
            mbevents = True
            Stop
        End If
        
        
        mbevents = False
        .Unprotect
        'new tomorrow1()
        tomorrow = n_date + 1
        tm_day = Day(tomorrow)
        tm_month = Month(tomorrow)
        tm_yr = Year(tomorrow)
        tm_date = DateSerial(tm_yr, tm_month, tm_day)
        
        'new yesterday1()
        yesterday = n_date - 1
        yd_day = Day(yesterday)
        yd_month = Month(yesterday)
        yd_yr = Year(yesterday)
        yd_date = DateSerial(yd_yr, yd_month, yd_day)
        
        .Range("J2") = Format(yd_date, "ddd mmm dd yyyy")
        .Range("P2") = Format(tm_date, "ddd mmm dd yyyy")
        mbevents = True
        .Protect
        
        Set rng_tas = .Range("I6:I47")
        Set rng_tae = .Range("J6:J47")
        Set rng_trc = .Range("H6:H47")
        Set ta = .Range(Target.Address)
        ta_r = ta.Row
        ta_c = ta.Column
        
        '.Range(ta).Value
        'MsgBox Target.Address & " has been changed."
        mbevents = True
        .Protect
    End With
End Sub

This is the code that is actually changing the worksheet contents:
NOTE: In the code I have that calls this procedure, I have the line
Code:
With ws_gui1
     .unprotect
     staff1

VBA Code:
Sub STAFF1()
    Dim strFile As String
    Dim fname As String

    fname = "SOP Schedule.xlsm"
    strFile = "D:\WSOP 2020\" & fname
    If Not FileExists(strFile) Then
        MsgBox "A critical application file is missing." & Chr(13) & "Unable to continue process.", vbCritical, "CRITICAL ERROR: SOP Schedule.xlsm"
        Stop
    End If
    xRet = IsWorkBookOpen(fname)
    Application.ScreenUpdating = False
    If Not xRet Then
        Workbooks.Open strFile
        Workbooks(fname).Windows(1).Visible = False
    End If
    cd_file = Workbooks("Data_Prep.xlsm").Worksheets("GUI_1").Range("AP2").Value & ".xlsx"
    Set wb_data = Workbooks(cd_file)
    Set wb_staff = Workbooks(fname)
    Set ws_staff = wb_data.Worksheets("Staff")
    Set ws_master = wb_staff.Worksheets("MASTER")
    Set ws_roster = wb_staff.Worksheets("ROSTER")
    Application.ScreenUpdating = True
'Stop
    With ws_gui1
        'staffing header
        With .Range("AZ3")
            .Font.Name = "Arial Narrow"
            .Value = "STAFFING MASTER   " & Chr(207)
            .Characters(Len(.Value), 1).Font.Name = "Webdings" 'this is where I get my first error when I run this code ... after the cell value changes in the line above, the worksheet protects again
        End With
        With .Range("AZ3:BE3")
            .Merge
            .Interior.Color = RGB(0, 176, 80)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Color = vbWhite
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .Color = vbWhite
            End With
            .Range("AZ4:BE47").ClearContents
        End With
'Stop
        ws_roster.Range("X2:X44").ClearContents 'clear temp
        guidest = 4
        
        'populate staff schedule - on duty
        ws_staff.Range("A:G").ClearContents
        
        For r = 2 To 43 'step through each employee in roster (42)
            en = ws_roster.Cells(r, 5)
            team = ws_roster.Cells(r, 6)
            s_cid = ws_roster.Cells(r, 9) 'employee's master schedule column reference
            drow = Application.WorksheetFunction.Match(CDbl(n_date), ws_master.Columns(1), 0) 'master schedule date row
            'assess shift
            Shift = ws_master.Cells(drow, s_cid)
            If Shift <> "E1" And Shift <> "E2" And Shift <> "L1" And Shift <> "L1*" Then
                'Stop
                If Shift = "" Then
                    Shift = "RSO"
                End If
                If Shift = "**" Then
                    Shift = "RSO**"
                End If
                If Shift = "***" Then
                    Shift = "RSO***"
                End If
                ws_roster.Cells(r, 24) = Shift
            Else
                With .Cells(guidest, "AZ")
                    .Value = ws_roster.Cells(r, 23) & Shift
                    With .Validation
                        .Delete
                        If Left(team, 2) = "CU" Then
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                             xlBetween, Formula1:="=nr_cuperole"
                        Else
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                             xlBetween, Formula1:="=nr_studrole"
                        End If
                        .IgnoreBlank = True
                        .InCellDropdown = True
                        .ShowInput = True
                        .ShowError = True
                    End With
                End With
                ws_staff.Cells(guidest, 1) = ws_roster.Cells(r, 1)
                ws_staff.Cells(guidest, 2) = .Cells(guidest, "AZ")
                .Range("BA" & guidest & ":BC" & guidest).Merge
                .Cells(guidest, "BA") = en
                ws_staff.Cells(guidest, 3) = en
                .Cells(guidest, "BD") = ws_master.Cells(drow, s_cid + 1)
                ws_staff.Cells(guidest, 4) = .Cells(guidest, "BD")
                .Cells(guidest, "BE") = ws_master.Cells(drow, s_cid + 2)
                ws_staff.Cells(guidest, 5) = .Cells(guidest, "BE")
                guidest = guidest + 1
            End If
        Next r

'Stop
        lr_od = .Cells(.Rows.Count, "AZ").End(xlUp).Row 'last row of on duty staff range GUI_1
        cnt_ond = lr_od - 4 'on duty staff range (4:lr_od-4)
        With .Range("AZ4:AZ" & lr_od)
            .Locked = False
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        With .Range("BA4:BC" & lr_od)
            .Locked = False
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
        With .Range("BD4:BD" & lr_od)
            .Locked = False
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        With .Range("BE4:BE" & lr_od)
            .Locked = False
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        'bottom border
        With .Range("AZ4:BE" & lr_od)
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 9
                .TintAndShade = -0.249946592608417
                .Weight = xlHairline
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ThemeColor = 9
                .TintAndShade = -0.249946592608417
                .Weight = xlHairline
            End With
        End With
        .Range("BD4:BE" & lr_od).NumberFormat = "h:mmA/P"
           

'Stop

        'populate staff schedule - off duty

        cnt_offd = Application.WorksheetFunction.CountA(ws_roster.Range("X2:X43"))
        
        'off duty header
        ofd_head = lr_od + 2 'off duty range header row
        .Range("AZ" & ofd_head).Value = "OFF DUTY"
        With .Range("AZ" & ofd_head & ":BE" & ofd_head)
            .Font.Name = "Arial Narrow"
            .Font.Size = 10
            .Font.Italic = True
            .Font.Color = RGB(31, 78, 120)
            .Merge
            .HorizontalAlignment = xlCenter
            With .Borders
                .LineStyle = xlContinuous
                .Color = RGB(47, 117, 181)
                .Weight = xlMedium
            End With
        End With
'Stop
        ofdest = ofd_head + 1 'off duty range starting row
        For r = 2 To 43
            Shift = ws_roster.Cells(r, 24)
            Debug.Print Shift
            If Shift <> "" Then
                .Cells(ofdest, "AZ") = ws_roster.Cells(r, 5)
                ws_staff.Cells(guidest, 1) = ws_roster.Cells(r, 1)
                ws_staff.Cells(guidest, 3) = ws_roster.Cells(r, 5)
                
                .Cells(ofdest, "AZ").HorizontalAlignment = xlLeft
                Select Case Shift
                    Case Is = "RSO"
                        ofd_txt = "Scheduled Off"
                    Case Is = "RSO*"
                        ofd_txt = "Scheduled Off"
                    Case Is = "RSO**"
                        ofd_txt = "Scheduled Off"
                    Case Is = "RSO***"
                        ofd_txt = "Scheduled Off"
                    Case Is = "VAC"
                        ofd_txt = "Vacation"
                    Case Is = "999"
                        ofd_txt = "Off No Pay"
                    Case Is = "BRV"
                        ofd_txt = "Bereavement"
                    Case Is = "FTR"
                        ofd_txt = "Floater"
                    Case Is = "PER"
                        ofd_txt = "Personal"
                    Case Is = "STA"
                        ofd_txt = "Stat Day"
                    Case Else
                        ofd_txt = "Unknown"
                End Select
                .Cells(ofdest, "BC") = ofd_txt
                ws_staff.Cells(guidest, 2) = Shift
                guidest = guidest + 1
                With .Range("BC" & ofdest & ":BE" & ofdest)
                    .Merge
                    .HorizontalAlignment = xlCenter
                End With
                ofdest = ofdest + 1
            End If
        Next r
'Stop
        With .Range("AZ" & ofd_head + 1 & ":BE" & ofdest - 1)
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 9
                .TintAndShade = -0.249946592608417
                .Weight = xlHairline
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ThemeColor = 9
                .TintAndShade = -0.249946592608417
                .Weight = xlHairline
            End With
        End With
    End With
'Stop
End Sub
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
You're protecting the sheet at various points in the change event, including twice at the end of it.
 
Upvote 0
Thanks Fluff! I'm still working through at which point is best to protect the sheet. So many modules make changes to the worksheet, so poor planning of those modules impacts the protect and unprotect points.
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

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