View Single Post
 
Old 02-06-2025, 01:53 PM
gmaxey gmaxey is offline Windows 10 Office 2019
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,598
gmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nice
Default

Here is commented and modified code from yesterday. Put this code in a standard module name modMain. Interested in any input to streamline conflict validation, thoughts on thoroughness of the validation and answers to questions about the RegExp pattern. Thanks



Code:
Option Explicit
'A Public variable defined in the WorkBook Selection_Change event used to evaluate conflict with two similar tasks.
Public p_TargetVal As String
Sub Define_Highlight_Task(ByVal oRng As Range)
'Concept process developed and coded by Batman1
'Modified and commented by Greg Maxey to 1) provide error checking\validation of task definitions and 2) ask questions by Greg Maxey
Dim oRegEx As Object, varColors As Variant
Dim lngLength As Long, lngColor As Long, lngCol As Long, lngIndex As Long
Dim strText As String, strSep As String
Dim lngProcessRouter As Long

  lngProcessRouter = -9999 'Variable used to route processing based on conditions.
  'Define the task\events colors and add to variant array
  varColors = Array("15985347", "5296274", "12439801", "65535", "6908415", "0")
  'Determine the system decimal separator
  strSep = Mid(3 / 2, 2, 1) 'Or we could use strSep = Application.International(xlDecimalSeparator)
  
  'Evaluate the string entered in the active cell range (oRng)
  Set oRegEx = CreateObject("VBScript.RegExp")
  oRegEx.IgnoreCase = True 'Will match US and us etc.  Change to False if we want only US, BR, etc.
  strText = oRng.Value
  If UCase(strText) <> "L" Then
    'Define required code pattern. Batman1 original
    oRegEx.Pattern = "^((?:\d*\.)?\d+)(?:|\-)(US|UK|AP|BR|L).*$"
    '**********************************************REGEX PATTERN QUESTIONS**********************************************************
    '1. Could we use the system separator in the pattern ?? 'oRegEx.Pattern = "^((?:\d*\" & strSep & ")?\d+)(?:|\-)(US|UK|AP|BR|L).*$" _
    '2. In original, the "((?:\d*\.)?\d+)"
      'I understand that second "?" means the preceeing parenthetical elment (?:\d*\.) does not have to be found. _
      That the \d* represents 0 or more numbers, and the \. is a literal period (or in our case decimal separator). _
      But what is the purpose of "?:"
      'As best I can tell from testing.  The pattern can be rewritten either:
      'oRegEx.Pattern = "^((\d*\.)?\d+)(?:|\-)(US|UK|AP|BR|L).*$"
      'Where those two charcters just aren't used ...
      'or ... use a an OR |
      'oRegEx.Pattern = "^(\d*\.\d+|\d+)(?:|\-)(US|UK|AP|BR|L).*$"
    '3. Similiarliy, the "(?:|\-)".
      'I have deduced that signifies the "-" separating the number and region is not required.
      'But, what does the "?:" and "\" signify?
      'As best I can tell from testing.  The pattern can be rewritten:
      'oRegEx.Pattern = "^((\d*\.)?\d+)(-*)(US|UK|AP|BR|L).*$"
    '**********************************************END QUESTIONS**********************************************************
    'Test the target cell text (the task\event code entered) for match.
    If oRegEx.test(strText) Then
      'Based on the pattern and our code definition, we expect 1 match returned (Item 0), with 2 submatches.
      With oRegEx.Execute(strText).Item(0)
        'Using the match, use SubMatch(0) to determine task duration (numerical part of match)and Submatch(1) (alpha part of match) to determine color to apply.
        strText = .SubMatches(0)
        'Validate that the duration defined is a multiple of 0.25.  Note - If strSep (see questions above) is used in the pattern, then the Replace method won't be needed.
        If ((Replace(strText, ".", strSep)) * 100) Mod 25 = 0 Then
          lngLength = Replace(strText, ".", strSep) / 0.25
          'Determine color. SubMatch(1), will return either US, UK, AP, BR or L
          'InStr(1, USUKAPBR, SubMatch(1)) will return either 1, 3, 5, 7 or 9
          '(1-1) / 2 = 0, (3-1) / 2 = 1 and so on.
          lngColor = varColors((InStr(1, "USUKAPBRL", .SubMatches(1), vbTextCompare) - 1) / 2)
          'We have a valid code
          lngProcessRouter = 0
        Else
          'The duration is not defined as quarter hour increments.
          lngProcessRouter = 1
        End If
      End With
    End If
  Else
    'Just "L" defines the event leave for the rest of the shift.
    lngLength = 33 - oRng.Column + 1
    lngColor = varColors(4)
    'We have a valid definition.
    lngProcessRouter = 0
  End If
  If lngProcessRouter = 0 Then
    'Check for conflicts with an existing dissimilar or similar task\events at the target cell.
    Select Case True
      Case oRng.Interior.color <> 16777215 And oRng.Interior.color <> lngColor
        'We are in conflict with an existing dissimilar task e.g., We are trying to define and new break event that conflicts with an existing UK task.
        lngProcessRouter = 2
      Case oRng.Interior.color <> 16777215 And oRng.Interior.color = lngColor
        'We are in an existing similar task. Are we a) at the start of that task and attempting to redefine it or b) in conflict.
        'We captured the Target Cell value when we entered the cell. If that cell value is a null string then _
         b) we are in conflict with an existing task.
        If p_TargetVal = vbNullString Then lngProcessRouter = 2
    End Select
    If lngProcessRouter = 0 Then 'No conflicts.
      lngCol = oRng.Column
      'Clear the active cell color
      oRng.Interior.color = 16777215
      lngIndex = 1
      Do While ActiveSheet.Cells(oRng.Row, lngCol + lngIndex).Interior.color <> 16777215 And ActiveSheet.Cells(oRng.Row, lngCol + lngIndex).Value = ""
         'Clear subsequent cells until the next subsequent cell is a) already cleared or b) contains text (This would indicate the start of a different task\event).
         ActiveSheet.Cells(oRng.Row, lngCol + lngIndex).Interior.color = 16777215
         lngIndex = lngIndex + 1
      Loop
      'Is there time left in the shift for the task defined?
      If lngCol + lngLength <= 34 Then
        'Yes.
        'Ensure the defined task fits the timeline.
        For lngIndex = 1 To (lngLength - 1)
          If Not ActiveSheet.Cells(oRng.Row, lngCol + lngIndex).Interior.color = 16777215 Then
            'An existing task\event start on the time line before this task is finished.
            lngProcessRouter = 2 'Invalid task definition. Conflicts with existing task\event.
            Exit For
          End If
        Next
      Else
        'No, invalid task definition.  Exceeds shift time window.
        lngProcessRouter = 3
      End If
    End If
  End If
  Select Case lngProcessRouter
    Case Is = 0
      'Record and color code task on worksheet
      oRng.Resize(1, lngLength).Interior.color = lngColor
    Case Is = 1
      MsgBox "The task\event duration is not properly defined." & vbCr + vbCr _
            & "A Task\event duration must be defined in quarter hour increments.", vbInformation + vbOKOnly, "INVALID TASK\EVENT DEFINITION"
      oRng.Select
    Case Is = 2
      MsgBox "The defined task\event conflicts with\overlaps an existing task\event." & vbCr + vbCr _
              & "Redefine the task\event and try again.", vbInformation + vbOKOnly, "INVALID TASK\EVENT DEFINITION"
      oRng.Select
    Case Is = 3
      MsgBox "The task\event duration is not properly defined and exceeds the shift window.", _
            vbInformation + vbOKOnly, "INVALID TASK\EVENT DEFINITION"
      oRng.Select
  End Select
lbl_Exit:
  Set oRegEx = Nothing
  Exit Sub
End Sub
Put this code in the ThisWorkBook module:

Code:
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  'Fires after we define a task\event code and exist target cell.
  modMain.Define_Highlight_Task Target(1)
lbl_Exit:
  Exit Sub
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  'Fires when we move the selection into the target cell to define a task\event code. We need this information _
    to determine conflicts with similar task\events.
  If Target.Cells.Count = 1 Then p_TargetVal = Target.Value
lbl_Exit:
  Exit Sub
End Sub
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote