Ark68
Well-known Member
- Joined
- Mar 23, 2004
- Messages
- 4,564
- Office Version
- 365
- 2016
- Platform
- 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:
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.
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
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 SubHere 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 SubThis 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
