Dim oSheet As Worksheet
Dim varCodes, varCats, varColors
Sub ColorCodeSheets()
Dim lngIndex As Long
  varCodes = Split("US*15985347|UK*5296274|BR*65535|AP*12439801|L*6908415", "|")
  For Each oSheet In ThisWorkbook.Sheets
    For lngIndex = 0 To UBound(varCodes)
      FindCat varCodes(lngIndex)
    Next
    Exit For
  Next
lbl_Exit:
  Exit Sub
End Sub
Function FindCat(strCode)
Dim oRng As Range
Dim strAddr As String
Dim strCat As String, lngColor As Long
  strCat = Split(strCode, "*")(0)
  lngColor = CLng(Split(strCode, "*")(1))
  With oSheet.UsedRange
    Set oRng = .Find(What:=strCat, LookIn:=xlValues)
    ProcessFind oRng, lngColor
    strAddr = oRng.Address
    If Not oRng Is Nothing Then
      On Error GoTo Err_GetOut
      Do
        Set oRng = .FindNext(oRng)
        ProcessFind oRng, lngColor
      Loop While Not oRng Is Nothing And oRng.Address <> strAddr
    End If
  End With
Err_GetOut:
  If Err.Number <> 0 Then Err.Clear
  On Error GoTo 0
  Set oRng = Nothing
lbl_Exit:
  Exit Function
End Function
Sub ProcessFind(oRng As Range, lngColor As Long)
Dim varParts
Dim lngLen As Long
  varParts = Split(oRng.Value, "-")
  If UBound(varParts) = 1 Then
    lngLen = varParts(0) / 0.25
  Else
    lngLen = 32
  End If
  oRng.Resize(1, lngLen).Interior.Color = lngColor
lbl_Exit:
  Exit Sub
End Sub

Option Explicit

Sub ColorRanges()
Dim i As Long, firstAddr As String, code, colors, sh As Worksheet, rng As Range, re As Object
    Set re = CreateObject("VBScript.RegExp")
    code = Array("US", "UK", "BR", "AP", "L")
    colors = Array(RGB(0, 0, 255), RGB(0, 255, 0), RGB(255, 255, 0), RGB(255, 165, 0), RGB(255, 69, 0))
    For Each sh In ThisWorkbook.Worksheets
        For i = 0 To UBound(code)
            With sh.UsedRange
                Set rng = .Find(code(i), LookIn:=xlValues)
                If Not rng Is Nothing Then
                    firstAddr = rng.Address
                    Do
                        highlight code(i), colors(i), rng, re
                        Set rng = .FindNext(rng)
                    Loop While firstAddr <> rng.Address
                End If
            End With
        Next i
    Next sh
    Set re = Nothing
End Sub

Sub highlight(ByVal code As String, ByVal color As Long, ByVal rng As Range, ByVal re As Object)
Dim length As Long, text As String, separator As String, colors
    separator = Mid(3 / 2, 2, 1)    ' for runing when the decimal separator is a comma
    text = rng.Value
    If text <> "L" Then
        re.Pattern = "^((?:\d+\.)?\d+)(?:|\-)" & code & ".*$"
        If re.test(text) Then
            text = re.Replace(text, "$1")
            length = Replace(text, ".", separator) / 0.25
        End If
    Else
        length = 33 - rng.Column + 1
    End If
    If length Then rng.Resize(1, length).Interior.color = color
End Sub

Option Explicit

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    highlight_cell Target(1)
End Sub

Sub highlight_cell(ByVal rng As Range)
Dim length As Long, color As Long, text As String, separator As String, colors, re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.IgnoreCase = True
    colors = Array(RGB(0, 0, 255), RGB(0, 255, 0), RGB(255, 255, 0), RGB(255, 165, 0), RGB(255, 69, 0))
    separator = Mid(3 / 2, 2, 1)
    text = rng.Value
    If UCase(text) <> "L" Then
        re.Pattern = "^((?:\d+\.)?\d+)(?:|\-)(US|UK|BR|AP).*$"
        If re.test(text) Then
            With re.Execute(text).Item(0)
                text = .SubMatches(0)
                length = Replace(text, ".", separator) / 0.25
                color = colors((InStr(1, "USUKBRAPL", .SubMatches(1), vbTextCompare) - 1) / 2)
            End With
        End If
    Else
        length = 33 - rng.Column + 1
        color = colors(4)
    End If
    If length Then rng.Resize(1, length).Interior.color = color
    Set re = Nothing
End Sub

re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)" & code & ".*$"

re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)(US|UK|BR|AP).*$"

Sub highlight_cell(ByVal rng As Range)
Dim length As Long, color As Long, text As String, separator As String, colors, re As Object
'*** Added - GKMA
Dim lngCol As Long, lngIndex As Long
  lngCol = rng.Column
  'Clear any existing color coding.
  If rng.Interior.color <> 16777215 Then
    rng.Interior.color = 16777215
    lngIndex = 1
    Do While ActiveSheet.Cells(rng.Row, lngCol + lngIndex).Interior.color <> 16777215 And ActiveSheet.Cells(rng.Row, lngCol + lngIndex).Value = ""
      ActiveSheet.Cells(rng.Row, lngCol + lngIndex).Interior.color = 16777215
      lngIndex = lngIndex + 1
    Loop
  End If
'*** End add.
  Set re = CreateObject("VBScript.RegExp")
  re.IgnoreCase = True
  '*** GKM changed to more muted colors (the US blue was difficult to read)
  colors = Array("15985347", "5296274", "65535", "12439801", "6908415", "0")
  separator = Mid(3 / 2, 2, 1)
  text = rng.Value
  If UCase(text) <> "L" Then
    re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)(US|UK|BR|AP).*$"
    If re.test(text) Then
      With re.Execute(text).Item(0)
        text = .SubMatches(0)
        length = Replace(text, ".", separator) / 0.25
        color = colors((InStr(1, "USUKBRAPL", .SubMatches(1), vbTextCompare) - 1) / 2)
      End With
    End If
  Else
    length = 33 - rng.Column + 1
    color = colors(4)
  End If
  '*** Modified GKM
  If lngCol + length <= 34 Then
    If length Then rng.Resize(1, length).Interior.color = color
  Else
    MsgBox "The defined task duration exceeds the shift period."
  End If
  Set re = Nothing
  '*** End mods
End Sub

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

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