Quote:
Originally Posted by Seeker2025
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