Worksheet Change and WorksheetDoubleClick events Not Working - Poor range definitions?

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,698
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have this worksheet change code that monitors for changes throughout my entire Excel VBA project.

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 Sub

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.

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 Sub

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.

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 Sub

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!
 

Some videos you may like

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,698
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
For problem 1, I realize now that the range are being reset to the initial default values everytime the worksheet changes. I need these lines to prevent errors when the user makes initial changes to the worksheet, but they should not be reset once they have been properly created.

Any workaround?
 

Watch MrExcel Video

Forum statistics

Threads
1,114,139
Messages
5,546,184
Members
410,731
Latest member
keobongmacao
Top