Ark68
Well-known Member
- Joined
- Mar 23, 2004
- Messages
- 4,616
- Office Version
- 365
- 2016
- Platform
- Windows
I have this worksheet change code that monitors for changes throughout my entire Excel VBA project.
When my worksheet (ws_gui1) is first opened, the only cells available to be changed by user is D2, E2 or F2. The "true purposeful" ranges subject to change by the user, rng_role and rng_sstart, are not yet defined becaue they do not exist. They are created later on in the process (module: STAFF1 - this creates the dataset for which the ranges are applied) after they accept the values (via a submit button) of D2, E2 and F2. Now, this immediately caused an error when the u ser changed either of the values in D2, E2, or F2. The worksheet change event code was triggered, but since rng_role and rng_sstart weren't defined yet, those lines threw errors ("Invalid procedure call or argument") when the worksheet change event was triggered. It avoid these errors, I had to set up useless and interim ranges for rng_role and rng_sstart. They have no use for their actual purpose later on. These ranges will be created for their practical needs as the code advances.
Now without errors, and the user's changes of D2, E2 or F2 accepted, the user presses submit and the code moves forward an eventually the module STAFF1 is launched. This module builds a dynamic dataset on the active worksheet (ws_gui1) in an area roughly bound by AZ4:BE48 (depends on the amount of data).
Note, variuable rng_role, rng_sstart and rng_send are publically declared as part of the worksheet opening code.
The lines highlighted in blue are where the ranges are created. They represent data in three columns of the "Staff On Duty" section for which the user can change. The change events are highlighted in blue in the worksheet change code (if not intersect (target,)). The cells in rng_role are validated with data validation rules.
Another range, rng_offduty, is also created to allow manipulation of off duty staff related data by the user. However, to edit the data in this range requires a doubleclick event to be triggered.
With this module completed, the protected worksheet is made available for the user to manipulate at their will within the available unlocked ranges (rng_role, rng_sstart, rng_send, rng_offduty). mbevents which I use to control whether events are triggered is =true, and application.enableevents=true, thus allowing worksheet change and doubleclick events.
I am experiencing two problems:
1) When the user changes the value in one of the cells defined in rng_role nothing happens. The worksheet change is not being triggered when the value changes. Could it be that the changed cell is being recognized as being in rng_role because rng_role isn't set up properly? I am out of ideas as to why this change isn't being recognized.
2) when I double click on a cell within rng_offduty expecting the worksheet doubleclick event to trigger for that range, I get my message "Nothing to see here" - the default message for a double click on a cell that has nothing to edit. It should trigger the event code for access of that range.
Any help with either of these two issue, or better yet both, would be so greatly appreciated. I anticipate the solutions will be simple. I always find the more I prepare a question, the easier the solution. Thank you all in advance!
Rich (BB 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 tgt_r As Double
If Not mbevents Then Exit Sub
With ws_gui1
.Unprotect
Set rng_role = .Range("AZ4:AZ4")
Set rng_sstart = .Range("BD4:BD4")
Set rng_send = .Range("BE4:BE4")
'---- 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
.Protect
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
.Protect
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
.Protect
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
Exit Sub
End If
If Not Intersect(Target, rng_role) Is Nothing Then 'CHANGE in staff start
tgt_r = .Range(Target.Address).Row
MsgBox "Staff Role - Row: " & tgt_r
'Stop
chgrole tgt_r
mbevents = True
Exit Sub
End If
If Not Intersect(Target, rng_sstart) Is Nothing Then 'CHANGE in staff start
Stop
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."
Stop
mbevents = True
Exit Sub
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")
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
mbevents = True
.Protect
End With
End SubWhen my worksheet (ws_gui1) is first opened, the only cells available to be changed by user is D2, E2 or F2. The "true purposeful" ranges subject to change by the user, rng_role and rng_sstart, are not yet defined becaue they do not exist. They are created later on in the process (module: STAFF1 - this creates the dataset for which the ranges are applied) after they accept the values (via a submit button) of D2, E2 and F2. Now, this immediately caused an error when the u ser changed either of the values in D2, E2, or F2. The worksheet change event code was triggered, but since rng_role and rng_sstart weren't defined yet, those lines threw errors ("Invalid procedure call or argument") when the worksheet change event was triggered. It avoid these errors, I had to set up useless and interim ranges for rng_role and rng_sstart. They have no use for their actual purpose later on. These ranges will be created for their practical needs as the code advances.
Now without errors, and the user's changes of D2, E2 or F2 accepted, the user presses submit and the code moves forward an eventually the module STAFF1 is launched. This module builds a dynamic dataset on the active worksheet (ws_gui1) in an area roughly bound by AZ4:BE48 (depends on the amount of data).
Note, variuable rng_role, rng_sstart and rng_send are publically declared as part of the worksheet opening code.
Rich (BB 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"
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
'Stop
'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
Set rng_sstart = .Range("BD4:BD" & lr_od)
Set rng_role = .Range("AZ4:AZ" & lr_od)
Set rng_send = .Range("BE4:BE" & lr_od)
'populate staff schedule - off duty
Stop
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
od = Application.WorksheetFunction.Match("OFF DUTY", .Columns("AZ"), 0)
'slr = .Cells(.Rows.Count, "AZ").End(xlUp).Row
Set rng_offduty = .Range("AZ" & ofd_head + 1 & ":AZ" & ofdest)
End With
'Stop
End SubThe lines highlighted in blue are where the ranges are created. They represent data in three columns of the "Staff On Duty" section for which the user can change. The change events are highlighted in blue in the worksheet change code (if not intersect (target,)). The cells in rng_role are validated with data validation rules.
Another range, rng_offduty, is also created to allow manipulation of off duty staff related data by the user. However, to edit the data in this range requires a doubleclick event to be triggered.
With this module completed, the protected worksheet is made available for the user to manipulate at their will within the available unlocked ranges (rng_role, rng_sstart, rng_send, rng_offduty). mbevents which I use to control whether events are triggered is =true, and application.enableevents=true, thus allowing worksheet change and doubleclick events.
I am experiencing two problems:
1) When the user changes the value in one of the cells defined in rng_role nothing happens. The worksheet change is not being triggered when the value changes. Could it be that the changed cell is being recognized as being in rng_role because rng_role isn't set up properly? I am out of ideas as to why this change isn't being recognized.
2) when I double click on a cell within rng_offduty expecting the worksheet doubleclick event to trigger for that range, I get my message "Nothing to see here" - the default message for a double click on a cell that has nothing to edit. It should trigger the event code for access of that range.
Rich (BB code):
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Stop
Cancel = True
Dim rng_permit As Range, rng_cdata As Range
With ws_gui1
If page = 2 Then 'executes only with a date specified page, not the ActiveNet Page
'MsgBox Target.Address
'MsgBox Target.Row
'MsgBox Target.Column
'
Set tgt = Target
'MsgBox tgt
tgt_r = Target.Row
tgt_c = Target.Column
Set rng_permit = .Range("C6:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
Set rng_cdata = .Range("AP4:AP" & .Cells(.Rows.Count, "AP").End(xlUp).Row)
'Set rng_sname = .Range("BA4:BA" & .Cells(.Rows.Count, "BA").End(xlUp).Row)
'Set rng_sstart = .Range("BD4:BD" & .Cells(.Rows.Count, "BD").End(xlUp).Row)
'Set rng_send = .Range("BE4:BE" & .Cells(.Rows.Count, "BE").End(xlUp).Row)
'Set rng_asgmt = .Range("AM4:AM" & .Cells(.Rows.Count, "AM").End(xlUp).Row)
If Not Intersect(Target, rng_permit) Is Nothing Then 'doubleclick in permit range
MsgBox "Permit range - Row: " & tgt_r
sel_permit
ElseIf Not Intersect(Target, rng_cdata) Is Nothing Then 'doubleclick in coredata stats range
MsgBox "Core Data - Row: " & tgt_r
sel_coredata
ElseIf Not Intersect(Target, rng_offduty) Is Nothing Then 'doubleclick in assignment start
MsgBox "Assignment Start - Row: " & tgt_r & Chr(13) & "Extend booking data"
Stop
Else
MsgBox "Nothing to see here."
End If
End If
'Cancel = False
End With
End SubAny help with either of these two issue, or better yet both, would be so greatly appreciated. I anticipate the solutions will be simple. I always find the more I prepare a question, the easier the solution. Thank you all in advance!
