Change multiple text within cell to red

[Jim28]

Dear all

I have written the below code that looks for two types of codes; a NIU code abd CAR code within the text of the activecell.

What I wish to add to this code is the ability once a NIU or CAR is found is for the code to be changed to red within the activecell.

It is important to note that there may be zero or many of these to change within the activecell.

Is this possible to do? Thanks in advance for your thoughts.

Jim

Sub Macro1()
'
' Macro1 Macro
'
 
'
 
Dim Pos As Variant
Dim str As Variant
Dim comparison1 As Variant
Dim comparison2 As Variant
Dim NIU As Variant
Dim CAR As Variant
Dim end_Pos As Variant
Dim Start_Pos As Variant
 
 
comparison1 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 
comparison2 = "0123456789"
 
Do
 
str = UCase(ActiveCell)
 
NIU = 0
CAR = 0
Pos = 1
end_Pos = Len(str)
 
'searches for NIU code in format of letter, 4 numbers, letter eg K1435G
Do Until end_Pos < 6 Or end_Pos - Pos = 5
 
If InStr(1, comparison1, Mid(str, Pos, 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, (Pos + 1), 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, (Pos + 2), 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, (Pos + 3), 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, (Pos + 4), 1), vbTextCompare) > 0 Then
If InStr(1, comparison1, Mid(str, Pos + 5, 1), vbTextCompare) > 0 Then
NIU = NIU + 1
End If
End If
End If
End If
End If
End If
 
Pos = Pos + 1
 
Loop
 
Pos = 1
 
'searches for CAR code in format of 3 letters, 3 numbers, eg KSA143
 
Do Until end_Pos < 6 Or end_Pos - Pos = 5
 
If InStr(1, comparison1, Mid(str, Pos, 1), vbTextCompare) > 0 Then
If InStr(1, comparison1, Mid(str, (Pos + 1), 1), vbTextCompare) > 0 Then
If InStr(1, comparison1, Mid(str, (Pos + 2), 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, (Pos + 3), 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, (Pos + 4), 1), vbTextCompare) > 0 Then
If InStr(1, comparison2, Mid(str, Pos + 5, 1), vbTextCompare) > 0 Then
CAR = CAR + 1
End If
End If
End If
End If
End If
End If
 
Pos = Pos + 1
 
Loop
 
 
If NIU + CAR = 0 Then
 
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
 
ElseIf NIU = 1 And CAR = 1 Then
 
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65280
.TintAndShade = 0
.PatternTintAndShade = 0
End With
 
Else
 
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
 
End If
 
ActiveCell.Offset(1, 0).Select
 
Loop Until IsEmpty(ActiveCell) = True

 

[Jim28]

Anyone?

 

[Krishnakumar]

Hi,

In workbook module

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Reset
    On Error GoTo 0
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

    Dim cmdBBtn         As CommandBarButton
    Dim TextToFormat    As String
    Dim x, i            As Long
    Dim dic             As Object
    
    On Error Resume Next
    Application.CommandBars("Cell").Reset
    If Len(ActiveCell.Value) = 0 Then Exit Sub
    
    TextToFormat = ActiveCell.Text
    
    Application.CommandBars("Cell").Reset
    With Application.CommandBars("Cell").Controls
        With .Add
            .BeginGroup = True
            .Caption = "Reset Active Cell"
            .OnAction = "ResetActiveCell"
        End With
        With .Add
            .Caption = "Format Everything"
            .OnAction = "FormatEverything"
        End With
        x = Split(TextToFormat, " ")
        Set dic = CreateObject("scripting.dictionary")
            dic.comparemode = 1
        For i = 0 To UBound(x)
            If Not dic.exists(x(i)) Then
                dic.Add x(i), Nothing
                With .Add
                    .Caption = x(i)
                    .OnAction = "BoldAndColor"
                    .Tag = i + 1
                End With
            End If
        Next
    End With
    On Error GoTo 0

End Sub

In Standard module

Sub BoldAndColor()
    
    Dim aCell   As Range
    Dim Pos     As Long
    Dim l       As Long
    Dim i       As Long, x
    Dim txt     As String
    Dim cTag    As Long
    
    
    Set aCell = ActiveCell
    x = Split(aCell.Text, " ")
    
    cTag = CLng(Application.CommandBars.ActionControl.Tag)
    
    txt = LCase$(x(cTag - 1))
    l = Len(txt)
    For i = 0 To UBound(x)
        Pos = Pos + Len(x(i)) + 1
        If LCase$(x(i)) = txt Then
            With aCell.Characters(Pos - l, l)
                '.Font.Bold = True
                .Font.Color = 255
            End With
        End If
    Next
    
End Sub

Right click on any cell and select the word to format.

 

[Krishnakumar]

Hi

Add these 2 routines into Standard module, which I missed.

Sub ResetActiveCell()
    With ActiveCell
        .Font.Bold = False
        .Font.Color = 0
    End With
End Sub
Sub FormatEverything()
    With ActiveCell
        .Font.Bold = True
        .Font.Color = 255
    End With
End Sub