Macro that will turn any text (bracketed) to red

[JasonNeedsHelp]

Hello All,

I created two condition formats for the range of G1017:G4007 to turn certain text red.

First Condition format, if cell contains text "No EN Worker Category", works so no need to change this unless the macro will effect this.

The second Condition format is what I would like to be replaced with a macro. I want any text in (bracketed) to turn red and only the text in (brackets).

Attached excel sheet for your reference. EN BG Report (Master) v2.2.3.xlsm

In column M, I made a example of what the macro should do. In row 1037 and 1051 only the (bracketed) is red while the rest remains black.

Hope this was clear.

Thanks,

Jason

[6StringJazzer]

Add this code to the Sheet module for Sheet1 (Group Leader Summary). I have tested this.

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim C As Range
   
   For Each C In Target
      C.Font.Color = RGB(0, 0, 0)
      PaintParens C
   Next C
   
End Sub

Private Sub PaintParens(C As Range)
   
   Dim SStart As Long
   Dim SEnd As Long
      
   SStart = 1
   
   Do While SStart < Len(C.Value)
   
      Do While SStart < Len(C.Value) And Mid(C.Value, SStart, 1) <> "("
         SStart = SStart + 1
      Loop
      
      If SStart < Len(C.Value) Then
         SEnd = SStart + 1
         Do While SEnd < Len(C.Value) And Mid(C.Value, SEnd, 1) <> ")"
            SEnd = SEnd + 1
         Loop
         If SEnd > Len(C.Value) Then
            MsgBox ("Mismatched parentheses in " & C.Address & " =" & C.Value)
         Else
            C.Characters(Start:=SStart, Length:=SEnd - SStart + 1).Font.Color = RGB(255, 0, 0)
         End If
      End If
      
      SStart = SStart + 1
   Loop

End Sub

[JasonNeedsHelp]

Add this code to the Sheet module for Sheet1 (Group Leader Summary). I have tested this.

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim C As Range
   
   For Each C In Target
      C.Font.Color = RGB(0, 0, 0)
      PaintParens C
   Next C
   
End Sub

Private Sub PaintParens(C As Range)
   
   Dim SStart As Long
   Dim SEnd As Long
      
   SStart = 1
   
   Do While SStart < Len(C.Value)
   
      Do While SStart < Len(C.Value) And Mid(C.Value, SStart, 1) <> "("
         SStart = SStart + 1
      Loop
      
      If SStart < Len(C.Value) Then
         SEnd = SStart + 1
         Do While SEnd < Len(C.Value) And Mid(C.Value, SEnd, 1) <> ")"
            SEnd = SEnd + 1
         Loop
         If SEnd > Len(C.Value) Then
            MsgBox ("Mismatched parentheses in " & C.Address & " =" & C.Value)
         Else
            C.Characters(Start:=SStart, Length:=SEnd - SStart + 1).Font.Color = RGB(255, 0, 0)
         End If
      End If
      
      SStart = SStart + 1
   Loop

End Sub

Thanks Jeff,

I pasted this into a module... but how do i run this? I don't see it in the list of macro's to run.

[6StringJazzer]

You can't just paste it into a module, you must paste it into the module for the sheet containing this data.

It will run automatically any time a cell on that sheet is changed.

[JasonNeedsHelp]

You can't just paste it into a module, you must paste it into the module for the sheet containing this data.

It will run automatically any time a cell on that sheet is changed.

Thanks 6StringJazzer,

I pasted it into the sheet and seemed to work but it doesn't as I only want the (bracketed) text to turn red. Also there were some anomalies...

Example: "HWWL (PMSS) SAW" would remain all black, but I want the "PMSS" to turn red.
Example: "(PMSS) SC-HW" would turn all red, but I want the "SC-HW" to remain black.

Thanks,

[Philb1]

Hi Jason
The worksheet change code below will do what you want for the range in Column M on your example. It will change the text colour to red from the first "(" in a cell to the last ")" in a cell. I don't know if you want to restrict it to a range or do the whole sheet. Copy & paste it into the sheet module to test.

Private Sub Worksheet_Change(ByVal Target As Range) ' Column M only

Dim Bracket1 As Long, Bracket2 As Long, Bracket3 As Long
Dim RedTextRange As Range
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

    Set RedTextRange = Me.Range(Me.Cells(1017, 13), Me.Cells(Rows.Count, 13).End(xlUp))

On Error GoTo ErrorOut
'   Anything outside the target range, do nothing
If Intersect(Target, RedTextRange) Is Nothing Then

Exit Sub

'   Anything in the target range
    ElseIf Not Intersect(Target, RedTextRange) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        Bracket1 = InStr(Target, B1) ' Beginning bracket position
        Bracket2 = InStr(Target, B2) ' Ending bracket position
        Bracket3 = InStr(Bracket2 + 1, Target, B2) ' Test for a another ending bracket position

        If Not Bracket1 = 0 And Not Bracket2 = 0 Then

            If Bracket3 = 0 Then
                Target.Characters(Bracket1, Bracket2).Font.Color = vbRed
            Else ' If there is a another ending bracket, red text between 1st & last bracket
                Target.Characters(Bracket1, Bracket3).Font.Color = vbRed
            End If

        End If
    End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    Exit Sub

ErrorOut:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

End Sub

[Philb1]

Here is some code that will loop through column M & colour the cell text as desired. Put it in a normal module & call the macro from a button.

Option Explicit

Sub RedText()
Application.ScreenUpdating = False

Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Sheets(1)
Dim rCell As Range
Dim Bracket1 As Long, Bracket2 As Long, Bracket3 As Long
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

'   Column M is 13th column, change to suit
For Each rCell In Ws1.Range(Ws1.Cells(1017, 13), Ws1.Cells(Rows.Count, 13).End(xlUp))

    Bracket1 = InStr(rCell, B1) ' Beginning bracket position
    Bracket2 = InStr(rCell, B2) ' Ending bracket position
    Bracket3 = InStr(Bracket2 + 1, rCell, B2) ' Test for a another ending bracket position
    
    If Not Bracket1 = 0 And Not Bracket2 = 0 Then
    
        If Bracket3 = 0 Then
            rCell.Characters(Bracket1, Bracket2).Font.Color = vbRed
        Else ' If there is a another ending bracket, red text between 1st & last bracket
            rCell.Characters(Bracket1, Bracket3).Font.Color = vbRed
        End If
    
    End If

Next rCell

Application.ScreenUpdating = True

Exit Sub

End Sub

[JasonNeedsHelp]

Here is some code that will loop through column M & colour the cell text as desired. Put it in a normal module & call the macro from a button.

Option Explicit

Sub RedText()
Application.ScreenUpdating = False

Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Sheets(1)
Dim rCell As Range
Dim Bracket1 As Long, Bracket2 As Long, Bracket3 As Long
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

'   Column M is 13th column, change to suit
For Each rCell In Ws1.Range(Ws1.Cells(1017, 13), Ws1.Cells(Rows.Count, 13).End(xlUp))

    Bracket1 = InStr(rCell, B1) ' Beginning bracket position
    Bracket2 = InStr(rCell, B2) ' Ending bracket position
    Bracket3 = InStr(Bracket2 + 1, rCell, B2) ' Test for a another ending bracket position
    
    If Not Bracket1 = 0 And Not Bracket2 = 0 Then
    
        If Bracket3 = 0 Then
            rCell.Characters(Bracket1, Bracket2).Font.Color = vbRed
        Else ' If there is a another ending bracket, red text between 1st & last bracket
            rCell.Characters(Bracket1, Bracket3).Font.Color = vbRed
        End If
    
    End If

Next rCell

Application.ScreenUpdating = True

Exit Sub

End Sub

Thanks Philb1,

Two options... nice.

I tried the Macro one and works... but I noticed a couple anomalies...

for "(OER) (SC-C) (SC-HW)" , the "(OER) (SC-C)" would be red and the (SC-HW) is still black.
for "HWWL (PMSS) SAW" , the "(PMSS) SAW" would be red; not sure why it didn't see the end bracket?

I also noticed this turns the whole line red if it is a reference from another location. ie; ='Sheer1'!A1 as opposed to the text typed out as "xxx (xxx) xxx". This isn't a big issue but be nice to be able to use on a reference.

[amartinez988]

I know that you have the answers already, but just as an addiction, you could also use CONDITIONAL FORMATTING for this. Works fast and easy to do.
If you are interested let me know

[JasonNeedsHelp]

I know that you have the answers already, but just as an addiction, you could also use CONDITIONAL FORMATTING for this. Works fast and easy to do.
If you are interested let me know

Hi amartinez,

Yes, I know. But the challenge is that I only want part of the text to be red not the whole cell. Condition Format effects the whole cell.

[amartinez988]

Got you!

[Keebellah]

Integrate this part of the code and it will work

Sub testing()
Dim l   As Integer
Dim i   As Integer
Dim r   As Boolean
l = Len(ActiveCell.Value)
For i = 1 To l
    If Mid(ActiveCell.Value, i, 1) = ")" Then r = False
    With ActiveCell.Characters(Start:=i, Length:=1).Font
        Select Case r
        Case Is = True
            .Color = vbRed
        Case Else
            .Color = vbBlack
        End Select
    End With
    If Mid(ActiveCell.Value, i, 1) = "(" Then r = True
    If Mid(ActiveCell.Value, i, 1) = ")" Then r = False
Next i
End Sub

Place the module the worksheet, select a cell in your column M and then run this macro

[jindon]

1) You need to delete 1st conditional format otherwise it overrides changes by macro.
2) You can either call "test" macro my selecting "test" via Alt + F8 or just change the cell(s).

To a sheet code module

Private Sub Worksheet_Change(ByVal Target As Range)
    Set myRng = Intersect(Target, Range("G1017:G4007"))
    If Not myRng Is Nothing Then test
    Set myRng = Nothing
End Sub

To a Standard code module

Option Explicit
Public myRng As Range

Sub test()
    Dim r As Range, m As Object
    If myRng Is Nothing Then Set myRng = Sheets("Group Leader Summary").Range("G1017:G4007")
    myRng.Font.ColorIndex = xlAutomatic
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\([^\)]+(?=\))"
        For Each r In myRng
            For Each m In .Execute(r.Value)
                r.Characters(m.firstindex + 2, m.Length - 1).Font.Color = vbRed
            Next
        Next
    End With
End Sub

See attached.

[Philb1]

This will find the last ")" & colour all the text in between the first "(" & the last ")" red

Private Sub Worksheet_Change(ByVal Target As Range) ' Column M only

Dim Bracket1 As Long, Bracket2 As Long, Bracket3 As Long
Dim RedTextRange As Range
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

    Set RedTextRange = Me.Range(Me.Cells(1017, 13), Me.Cells(Rows.Count, 13).End(xlUp))

On Error GoTo ErrorOut
'   Anything outside the target range, do nothing
If Intersect(Target, RedTextRange) Is Nothing Then

Exit Sub

'   Anything in the target range
    ElseIf Not Intersect(Target, RedTextRange) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        Bracket1 = InStr(Target, B1) ' Beginning bracket position
        Bracket2 = InStr(Target, B2) ' Ending bracket position
        Bracket3 = InStrRev(rCell, B2) ' Test for another ending bracket position

        If Not Bracket1 = 0 And Not Bracket2 = 0 Then

            If Bracket3 = 0 Then
                Target.Characters(Bracket1, Bracket2).Font.Color = vbRed
            Else ' If there is another ending bracket, red text between 1st & last bracket
                Target.Characters(Bracket1, Bracket3).Font.Color = vbRed
            End If

        End If
    End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    Exit Sub

ErrorOut:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

End Sub

Option Explicit

Sub RedText()
Application.ScreenUpdating = False

Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Sheets(1)
Dim rCell As Range
Dim Bracket1 As Long, Bracket2 As Long, Bracket3 As Long
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

'   Column M is 13th column, change to suit
For Each rCell In Ws1.Range(Ws1.Cells(1017, 13), Ws1.Cells(Rows.Count, 13).End(xlUp))

    Bracket1 = InStr(rCell, B1) ' Beginning bracket position
    Bracket2 = InStr(rCell, B2) ' Ending bracket position
    Bracket3 = InStrRev(rCell, B2) ' Test for a another ending bracket position
    
    If Not Bracket1 = 0 And Not Bracket2 = 0 Then
    
        If Bracket3 = 0 Then
            rCell.Characters(Bracket1, Bracket2).Font.Color = vbRed
        Else ' If there is a another ending bracket, red text between 1st & last bracket
            rCell.Characters(Bracket1, Bracket3).Font.Color = vbRed
        End If
    
    End If

Next rCell

Application.ScreenUpdating = True

Exit Sub

End Sub

[Philb1]

Shorter versions below.
I've been thinking of doing something like this to one of my journal books & until now, have been to lazy lol. Killed 2 birds with 1 stone

Sub RedText()
Application.ScreenUpdating = False

Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Sheets(1)
Dim rCell As Range
Dim Bracket1 As Long, Bracket2 As Long
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

'   Column M is 13th column, change to suit
For Each rCell In Ws1.Range(Ws1.Cells(1017, 13), Ws1.Cells(Rows.Count, 13).End(xlUp))

    Bracket1 = InStr(rCell, B1) ' First opening bracket position
    Bracket2 = InStrRev(rCell, B2) ' Last closing bracket position
    
    If Not Bracket1 = 0 And Not Bracket2 = 0 Then
    
        rCell.Characters(Bracket1, Bracket2).Font.Color = vbRed
    
    End If

Next rCell

Application.ScreenUpdating = True

Exit Sub

End Sub

Private Sub Worksheet_Change(ByVal Target As Range) ' Column M only

Dim Bracket1 As Long, Bracket2 As Long
Dim RedTextRange As Range
Dim B1 As String, B2 As String
B1 = "("
B2 = ")"

    Set RedTextRange = Me.Range(Me.Cells(1017, 13), Me.Cells(Rows.Count, 13).End(xlUp))

On Error GoTo ErrorOut
'   Anything outside the target range, do nothing
    If Intersect(Target, RedTextRange) Is Nothing Then
    
    Exit Sub

'   Anything in the target range
    ElseIf Not Intersect(Target, RedTextRange) Is Nothing Then
    
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        Bracket1 = InStr(Target, B1) ' First Opening bracket position
        Bracket2 = InStrRev(Target, B2) ' Last closing bracket position

        If Not Bracket1 = 0 And Not Bracket2 = 0 Then

            Target.Characters(Bracket1, Bracket2).Font.Color = vbRed

        End If
        
    End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    Exit Sub

ErrorOut:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

End Sub

[protonLeah]

Option Explicit
Sub Black2Red()
    Dim StrLen          As Long, _
        StrtPos         As Long, _
        k               As Long, _
        rpl             As String, _
        LeftRightPos    As Variant
    
    StrLen = Len(Range("L1").Value)
    rpl = Replace(Range("L1").Value, "(", "")
    StrtPos = Len(rpl)
    StrLen = StrLen - StrtPos
    ReDim LeftRightPos(1 To StrLen, 1 To 2)
    StrtPos = 1
    For k = 1 To StrLen
        LeftRightPos(k, 1) = InStr(StrtPos, Range("L1").Value, "(")
        LeftRightPos(k, 2) = InStr(LeftRightPos(k, 1), Range("L1").Value, ")")
        Range("L1").Characters(Start:=LeftRightPos(k, 1) + 1, Length:=LeftRightPos(k, 2) - LeftRightPos(k, 1) - 1).Font.Color = vbRed
        StrtPos = LeftRightPos(k, 2) - 1
    Next k
End Sub

[Philb1]

Nice code ProtonLeah.
I thought about doing what you've done but I didn't know how to do it. I've worked out how your code works & now I do.
Thanks
Phil

[JasonNeedsHelp]

Option Explicit
Sub Black2Red()
    Dim StrLen          As Long, _
        StrtPos         As Long, _
        k               As Long, _
        rpl             As String, _
        LeftRightPos    As Variant
    
    StrLen = Len(Range("L1").Value)
    rpl = Replace(Range("L1").Value, "(", "")
    StrtPos = Len(rpl)
    StrLen = StrLen - StrtPos
    ReDim LeftRightPos(1 To StrLen, 1 To 2)
    StrtPos = 1
    For k = 1 To StrLen
        LeftRightPos(k, 1) = InStr(StrtPos, Range("L1").Value, "(")
        LeftRightPos(k, 2) = InStr(LeftRightPos(k, 1), Range("L1").Value, ")")
        Range("L1").Characters(Start:=LeftRightPos(k, 1) + 1, Length:=LeftRightPos(k, 2) - LeftRightPos(k, 1) - 1).Font.Color = vbRed
        StrtPos = LeftRightPos(k, 2) - 1
    Next k
End Sub

Not sure why.. but recieved a debug on

ReDim LeftRightPos(1 To StrLen, 1 To 2)

[protonLeah]

Philb1,
Thank you

[Keebellah]

Anybody take a look at this at all?

Public Sub RedTextModified()
Application.ScreenUpdating = False

Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Sheets(1)
Dim rCell As Range
Dim l   As Integer
Dim i   As Integer
Dim r   As Boolean

'   Column M is 13th column, change to suit
For Each rCell In Ws1.Range(Ws1.Cells(1, 13), Ws1.Cells(Rows.Count, 13).End(xlUp))
    l = Len(rCell.Value)
    For i = 1 To l
        If Mid(rCell.Value, i, 1) = ")" Then r = False
        With rCell.Characters(Start:=i, Length:=1).Font
            Select Case r
            Case Is = True
                .Color = vbRed
            Case Else
                .Color = vbBlack
            End Select
        End With
        If Mid(rCell.Value, i, 1) = "(" Then r = True
    Next i
Next rCell
Application.ScreenUpdating = True
End Sub

There are more than one ocurrences (...) (...)
This works

[JasonNeedsHelp]

Thanks All!

I tried all of these and they all seem to work. Now i just need to decide which one...

Thanks again!

[jindon]

Perhaps easiest to understand.

Sub test()
    Dim r As Range, x As Long, y As Long
    If myRng Is Nothing Then Set myRng = Sheets("Group Leader Summary").Range("G1017:G4007")
    myRng.Font.ColorIndex = xlAutomatic
    For Each r In myRng
        y = InStrRev(r.Value, ")")
        Do While y
            x = InStrRev(r.Value, "(", y)
            If x Then
                r.Characters(x + 1, y - x).Font.Color = vbRed
            End If
            y = InStrRev(r.Value, ")", x)
        Loop
    Next
End Sub