Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 02-04-2025, 09:54 PM
Seeker2025 Seeker2025 is offline VBA code that will apply to certain cells based on their value Windows 11 VBA code that will apply to certain cells based on their value Office 2021
Novice
VBA code that will apply to certain cells based on their value
 
Join Date: Feb 2025
Posts: 2
Seeker2025 is on a distinguished road
Default VBA code that will apply to certain cells based on their value

Good day to everyone!



I am looking for a VBA code that will apply to certain cells based on their value.

I want to create a job pickup time tracker for three shifts in each sheet each day, each with different operators, and upon the duration of the job and the region that many cells to be highlighted.

Example1

Operator-1 picks a 1-hour duration job, and the job is from the UK region

The value I enter is 1-UK1234 were

1 is the 1-hour duration of the job
UK - Is the UK region code
1234 - Is the Job ID which is not standard

Then four cells to be highlighted considering each cell a 15-minute duration.

I have also attached the template and given sample data in this and manually highlighted the cells

But I would like to have a VBA code to highlight as many cells depend on the duration and region.

I want green color for the UK region jobs, Blue for the US region jobs, Orange for the AP region jobs, Yellow for Break, and Red for Leave.

Cheers.
Attached Files
File Type: xlsx PickupTracker.xlsx (50.4 KB, 8 views)
Reply With Quote
  #2  
Old 02-05-2025, 07:36 AM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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

Quote:
Originally Posted by Seeker2025 View Post
Good day to everyone!

I am looking for a VBA code that will apply to certain cells based on their value.

I want to create a job pickup time tracker for three shifts in each sheet each day, each with different operators, and upon the duration of the job and the region that many cells to be highlighted.

Example1

Operator-1 picks a 1-hour duration job, and the job is from the UK region

The value I enter is 1-UK1234 were

1 is the 1-hour duration of the job
UK - Is the UK region code
1234 - Is the Job ID which is not standard

Then four cells to be highlighted considering each cell a 15-minute duration.

I have also attached the template and given sample data in this and manually highlighted the cells

But I would like to have a VBA code to highlight as many cells depend on the duration and region.

I want green color for the UK region jobs, Blue for the US region jobs, Orange for the AP region jobs, Yellow for Break, and Red for Leave.

Cheers.

Seeker,


I have quite a bit of experience with VBA in Word, but just a dabbler with Excel VBA. You will most likely get a much better solution or even suggestions for a better way. Anyway, as I understand your requirement. You have these sheets where you manually enter your code sequences e.g. 2-US1234, .75-UK5679 etc. and you want a macro to apply your color coding. Correct?


If yes, then you will need to make a slight change to your codes. L for leave is fine as it is all day. However your coding for BR needs to be changed from .5BR, 1BR etc. to .5-BR, 1-BR to match the separator used for US, UK and AP. If you can do that, then this a macro may work for you:


Copy all of the code to a standard module. Run Color Code Sheets. If you don't like the colors applied the replace the *###### part in the varCodes to the number of the color you like.


Code:
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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #3  
Old 02-05-2025, 09:00 AM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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 Alternate

Quote:
Originally Posted by Seeker2025 View Post
Good day to everyone!

I am looking for a VBA code that will apply to certain cells based on their value.

I want to create a job pickup time tracker for three shifts in each sheet each day, each with different operators, and upon the duration of the job and the region that many cells to be highlighted.

Example1

Operator-1 picks a 1-hour duration job, and the job is from the UK region

The value I enter is 1-UK1234 were

1 is the 1-hour duration of the job
UK - Is the UK region code
1234 - Is the Job ID which is not standard

Then four cells to be highlighted considering each cell a 15-minute duration.

I have also attached the template and given sample data in this and manually highlighted the cells

But I would like to have a VBA code to highlight as many cells depend on the duration and region.

I want green color for the UK region jobs, Blue for the US region jobs, Orange for the AP region jobs, Yellow for Break, and Red for Leave.

Cheers.
Are you looking to define, create and color code you task\events individually? Yes?


Download the attached file. Unblock macros from running and open the file.
Dbl_click in in on of the time slot fields for an individual. Fill in the displayed userform or select a range time slot cells for an individual and press CTRL+SHIFT+E (this way your defined duration will auto populate when you select the task code.


BREAK


For any other experienced Excel users - I basically a nub with Excel VBA but got interested in this thread and took a stab at it. The differences between Excel range and Word Range seem legion. I certainly welcome any constructive criticism and any suggestions to improve the code or improve the OP's process.
Attached Files
File Type: xlsm PickupTracker Ver 1.1.xlsm (76.9 KB, 3 views)
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/

Last edited by gmaxey; 02-05-2025 at 02:55 PM.
Reply With Quote
  #4  
Old 02-05-2025, 03:29 PM
batman1 batman1 is offline VBA code that will apply to certain cells based on their value Windows 11 VBA code that will apply to certain cells based on their value Office 2013
Advanced Beginner
 
Join Date: Jan 2025
Posts: 57
batman1 is on a distinguished road
Default

Quote:
Originally Posted by Seeker2025 View Post
Then four cells to be highlighted considering each cell a 15-minute duration.
I don't understand what you wrote well. I don't know English, I use Google Translate.

1. You will enter values ​​into cells: B3, F3, I3, K3, M3, U3, AG3, B4, R4, V4, Z4, L5 --> you will run the code
Cod Module1
Code:
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
run ColorRanges code


2. You enter values ​​into cell B3 --> the code starts automatically
You enter values ​​into cell F3 --> the code starts automatically ...,
You enter values ​​into cell L5 --> kd starts automatically

Cod in Module ThisWorkbook
Code:
Option Explicit

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    highlight_cell Target(1)
End Sub
Cod in Module1
Code:
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
Reply With Quote
  #5  
Old 02-05-2025, 04:39 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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

Batman1


I tested both of your proposed solutions. They both work with "durations defined

as 1 or more e.g., 1-BR, 1.5-US, 2.5-AP etc. However, if duration is < 1 e.g., .25-BR, .5-US or .75-UK they are not being detected by your RegEx expression.


Unable to find expression to work in all cases.
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #6  
Old 02-05-2025, 05:15 PM
batman1 batman1 is offline VBA code that will apply to certain cells based on their value Windows 11 VBA code that will apply to certain cells based on their value Office 2013
Advanced Beginner
 
Join Date: Jan 2025
Posts: 57
batman1 is on a distinguished road
Default

Quote:
Originally Posted by gmaxey View Post
Batman1


I tested both of your proposed solutions. They both work with "durations defined

as 1 or more e.g., 1-BR, 1.5-US, 2.5-AP etc. However, if duration is < 1 e.g., .25-BR, .5-US or .75-UK they are not being detected by your RegEx expression.


Unable to find expression to work in all cases.
In the OP data I see 0.75-US, 0.5BR, 0.5AP, 0.25BR everywhere, so there is always at least 1 digit before the decimal separator. If we also accept .75-US, .5BR, .25BR, then just change:

1. In Sub highlight
Code:
re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)" & code & ".*$"
2. In Sub highlight_cell
Code:
re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)(US|UK|BR|AP).*$"
Reply With Quote
  #7  
Old 02-05-2025, 05:35 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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

The RegEx stuff is fascinating. I will have to try to break that down to understand the pieces and how it works.


Of course this is the OPs project, but I'm going to take your high_cell procedure and see if I can 1) Prohibit coloring outside the shift range and 2) redefine any existing coloring if the cell code is changed.


Thanks
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #8  
Old 02-05-2025, 06:07 PM
batman1 batman1 is offline VBA code that will apply to certain cells based on their value Windows 11 VBA code that will apply to certain cells based on their value Office 2013
Advanced Beginner
 
Join Date: Jan 2025
Posts: 57
batman1 is on a distinguished road
Default

I forgot to write: can be "-" or without, case-insensitive. Code accepts 1-UK1234, 1UK1234, 1-BR, 1-br, 1BR
Reply With Quote
  #9  
Old 02-05-2025, 06:12 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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 the revised procedure. Likely cobbled as I am not very familiar with Excel:

Code:
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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #10  
Old 02-05-2025, 06:22 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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

Quote:
Originally Posted by batman1 View Post
I forgot to write: can be "-" or without, case-insensitive. Code accepts 1-UK1234, 1UK1234, 1-BR, 1-br, 1BR

Good idea!


I thingk the next enhancement would be to ensure tasks can't overlap. For another day. It is getting late.



In the userform version I posted earlier, "L" or Leave can be a set 8 hours or defined with a start and end point. Will have to let OP decide what he wants and code can then be modified.


Have you posted a web page or any other material on construction of RegEx expressions? I've read quite a bit of on them since the last time you helped with one of those but still hard to grasp without good practical examples.
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #11  
Old 02-06-2025, 12:18 PM
batman1 batman1 is offline VBA code that will apply to certain cells based on their value Windows 11 VBA code that will apply to certain cells based on their value Office 2013
Advanced Beginner
 
Join Date: Jan 2025
Posts: 57
batman1 is on a distinguished road
Default

Quote:
Originally Posted by gmaxey View Post
Have you posted a web page or any other material on construction of RegEx expressions?

I have never published anything on any website
Reply With Quote
  #12  
Old 02-06-2025, 12:21 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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

Thanks. I'm still tinkering with the code yesterday to validate event\task definitions. I"ll post later, if you care to review and comment.
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #13  
Old 02-06-2025, 12:40 PM
batman1 batman1 is offline VBA code that will apply to certain cells based on their value Windows 11 VBA code that will apply to certain cells based on their value Office 2013
Advanced Beginner
 
Join Date: Jan 2025
Posts: 57
batman1 is on a distinguished road
Default

I don't promise anything. I can analyze other people's codes but following other people's codes, train of thought is hard, difficult. I don't like it.
Reply With Quote
  #14  
Old 02-06-2025, 12:50 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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

Of course. I understand and usually feel the same way. I'm going to heavily comment and if not you then perhaps someone else will have a thought to share.
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #15  
Old 02-06-2025, 01:53 PM
gmaxey gmaxey is offline VBA code that will apply to certain cells based on their value Windows 10 VBA code that will apply to certain cells based on their value 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
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Formula or VBA code to format certain cells based on the cell value Seeker2025 Excel 1 02-03-2025 01:14 AM
Apply a formula based on whether a cell is blank or has a date NLJ Excel 4 09-17-2021 06:02 AM
VBA code that will apply to certain cells based on their value VBA Code apply draft lodi123 Word VBA 1 02-21-2017 04:55 AM
Conditional formating all cells in an array based on adjacent cells deejay Excel 6 12-20-2016 12:00 PM
Is it possible to have a style apply two formats based upon text? DMcCollum Word 3 05-02-2015 06:29 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 12:27 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft