![]() |
#1
|
|||
|
|||
![]()
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. |
#2
|
|||
|
|||
![]() Quote:
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 |
#3
|
|||
|
|||
![]() Quote:
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. Last edited by gmaxey; 02-05-2025 at 02:55 PM. |
#4
|
|||
|
|||
![]() Quote:
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 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 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 |
#5
|
|||
|
|||
![]()
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. |
#6
|
|||
|
|||
![]() Quote:
1. In Sub highlight Code:
re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)" & code & ".*$" Code:
re.Pattern = "^((?:\d*\.)?\d+)(?:|\-)(US|UK|BR|AP).*$" |
#7
|
|||
|
|||
![]()
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 |
#8
|
|||
|
|||
![]()
I forgot to write: can be "-" or without, case-insensitive. Code accepts 1-UK1234, 1UK1234, 1-BR, 1-br, 1BR
|
#9
|
|||
|
|||
![]()
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 |
#10
|
|||
|
|||
![]() Quote:
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. |
#11
|
|||
|
|||
![]() Quote:
I have never published anything on any website |
#12
|
|||
|
|||
![]()
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.
|
#13
|
|||
|
|||
![]()
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.
|
#14
|
|||
|
|||
![]()
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.
|
#15
|
|||
|
|||
![]()
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 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 |
![]() |
Thread Tools | |
Display Modes | |
|
![]() |
||||
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 |
![]() |
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 |