VBA to change color of partial text

[borkybork]

Hello,

I have the code below to change the color of the customer ID from black to red. I'm not sure what's wrong with the code but it only works on some worksheets. I need to keep the formatting the same for the first 3 lines (times new roman size 12, black and bolded), but somehow it changes them to arial, size 11, black and sometimes red (basically same as customer ID), and it also doesn't always change the customer ID to red. Is there anyway to make the code work for all the different project files? Like maybe input the prefix in a form or dialog box and have the code find it in the merged cell and change its color and all the characters that follow? I also don't intend to keep the macro in the project workbooks. Could someone please help? Thank you in advance!

For some background:
- A1:F1 is a merged cell
- the length of the prefixes vary (at least 1 character) and there's really no pattern to associate with the project name either
- The prefixes are always followed by a dash "-"
- The numbers are always 3 digits (ie. 001 - 999). So the customer ID format is "PREFIX-001" as an example.
- Customers may be an individual or an institution so they may have other characters (ie. periods, dashes, commas, etc.) and numbers in their names.

workbook 1 = Project Name (ie. Houston) with 200+ worksheets. Same customer ID "TX-###" prefix across all worksheets
workbook 2 = Project Name (ie. Miami) with 200+ worksheets. Same customer ID "FLORIDA-###" prefix across all worksheets
workbook 3 = Project Name (ie. Los Angeles) with 200+ worksheets. Same customer ID "LA-###" prefix across all worksheets
workbook 4 = Project Name (ie. Chicago) with 200+ worksheets. Same customer ID "CHI-###" prefix across all worksheets

default format:

format needed:

Sub Color2()

Dim Position As Integer, Letters As Integer
Dim WS As Worksheet
 
For Each WS In ActiveWorkbook.Worksheets
WS.Activate
Range("A1:F1").Select

    Position = InStrRev(ActiveCell.Text, vbLf)
    Letters = Len(ActiveCell.Text) - Position
    
If Position > 0 Then
    With ActiveCell.Characters(Start:=Position + 1, Length:=Letters)
        .Font.Color = vbRed
    End With
End If
Next WS
MsgBox "Done."
End Sub

 

[rlv01]

It might be better if you searched for the text you want to change the color of instead of the line feed character.

Sub Color2()
    Dim Position As Integer, Letters As Integer
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim ColoredText As String

    ColoredText = "Customer ID"

    For Each WS In ActiveWorkbook.Worksheets
        Set CellRange = WS.Range("A1")

        With CellRange
            Position = InStrRev(.Text, ColoredText, , vbTextCompare)
            Letters = Len(ColoredText)
                      
            With .Font
                .Name = "Times New Roman"
                .Size = 12
                .Bold = True
                .Color = vbBlack
            End With
            If Position > 0 Then
                With .Characters(Start:=Position, Length:=Letters)
                        .Font.Color = vbRed
                End With
            End If
        End With
    Next WS
    MsgBox "Done."
End Sub

 

[borkybork]

It might be better if you searched for the text you want to change the color of instead of the line feed character.

Sub Color2()
    Dim Position As Integer, Letters As Integer
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim ColoredText As String

    ColoredText = "Customer ID"

    For Each WS In ActiveWorkbook.Worksheets
        Set CellRange = WS.Range("A1")

        With CellRange
            Position = InStrRev(.Text, ColoredText, , vbTextCompare)
            Letters = Len(ColoredText)
                     
            With .Font
                .Name = "Times New Roman"
                .Size = 12
                .Bold = True
                .Color = vbBlack
            End With
            If Position > 0 Then
                With .Characters(Start:=Position, Length:=Letters)
                        .Font.Color = vbRed
                End With
            End If
        End With
    Next WS
    MsgBox "Done."
End Sub

Thanks for your response! I tried it with your code, but it changed the last line to black times new roman also. I replaced "Customer ID" with say "CHI-?". Not sure if I'm using it correctly though because it also didn't work. I have to use a wildcard because the 2nd part to the customer ID is unique in every worksheet.

 

[rlv01]

Sub Color2()
    Dim Position As Integer, Letters As Integer, I As Long
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim ColoredText As String, S As String
    Dim SA As Variant
    Dim SkipSheet As Boolean

    For Each WS In ActiveWorkbook.Worksheets
        Set CellRange = WS.Range("A1")
        S = Replace(Replace(Replace(CellRange.Value, vbCrLf, vbLf), vbCr, vbLf), vbLf & vbLf, vbLf)
        Do While Right(S, 1) = vbLf
            S = Left(S, Len(S) - 1)
        Loop
        CellRange.Value = S
        SA = Split(S, vbLf)

        If UBound(SA) <> 3 Then
            WS.Activate
            CellRange.Select
            S = "The header cell must have 4 lines (1. Company, 2. Project Name, 3. Customer Name, and 4. Customer ID)" & vbCr & vbCr _
              & "This header cell has " & UBound(SA) + 1 & " lines instead of 4:" & vbCr
            For I = 0 To UBound(SA)
                S = S & I + 1 & ": '" & SA(I) & "'" & vbCr
            Next I
            S = S & vbCr & "Please repair cell (" & CellRange.Address(0, 0, , 1) & ")"
            Select Case MsgBox(S, vbOKCancel Or vbExclamation, Application.Name)

            Case vbOK
                SkipSheet = True
            Case vbCancel
                Exit Sub
            End Select
        End If

        If Not SkipSheet Then
            ColoredText = SA(UBound(SA))
            With CellRange
                Position = InStrRev(.Text, ColoredText, , vbTextCompare)
                Letters = Len(ColoredText)

                With .Font
                    .Name = "Times New Roman"
                    .Size = 12
                    .Bold = True
                    .Color = vbBlack
                End With
                If Position > 0 Then
                    With .Characters(Start:=Position, Length:=Letters)
                        .Font.Color = vbRed
                        .Font.Name = "Arial"
                        .Font.Size = 11
                    End With
                End If
            End With
        Else
            SkipSheet = False
        End If
    Next WS
    MsgBox "Done."
End Sub

 

[kevin9999]

I'm a bit late to this one, but please try the following.

Option Explicit
Sub colorString()
    Dim i As Long, s As String
    Dim wb As Workbook, ws As Worksheet
    Dim c As Range
    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet
    
    s = ws.Range("A1").Text
    i = InStrRev(s, vbLf) + 1
    s = WorksheetFunction.Trim(Mid(s, i, 100))
    
    For Each ws In wb.Worksheets
        Set c = ws.Range("A1")
        With Range("A1")
            For i = 1 To Len(c) - Len(s) + 1
                If Mid(c, i, Len(s)) = s Then
                    c.Characters(i, Len(s)).Font.Color = vbRed
                End If
            Next i
        End With
    Next ws

End Sub

 

[borkybork]

Sub Color2()
    Dim Position As Integer, Letters As Integer, I As Long
    Dim WS As Worksheet
    Dim CellRange As Range
    Dim ColoredText As String, S As String
    Dim SA As Variant
    Dim SkipSheet As Boolean

    For Each WS In ActiveWorkbook.Worksheets
        Set CellRange = WS.Range("A1")
        S = Replace(Replace(Replace(CellRange.Value, vbCrLf, vbLf), vbCr, vbLf), vbLf & vbLf, vbLf)
        Do While Right(S, 1) = vbLf
            S = Left(S, Len(S) - 1)
        Loop
        CellRange.Value = S
        SA = Split(S, vbLf)

        If UBound(SA) <> 3 Then
            WS.Activate
            CellRange.Select
            S = "The header cell must have 4 lines (1. Company, 2. Project Name, 3. Customer Name, and 4. Customer ID)" & vbCr & vbCr _
              & "This header cell has " & UBound(SA) + 1 & " lines instead of 4:" & vbCr
            For I = 0 To UBound(SA)
                S = S & I + 1 & ": '" & SA(I) & "'" & vbCr
            Next I
            S = S & vbCr & "Please repair cell (" & CellRange.Address(0, 0, , 1) & ")"
            Select Case MsgBox(S, vbOKCancel Or vbExclamation, Application.Name)

            Case vbOK
                SkipSheet = True
            Case vbCancel
                Exit Sub
            End Select
        End If

        If Not SkipSheet Then
            ColoredText = SA(UBound(SA))
            With CellRange
                Position = InStrRev(.Text, ColoredText, , vbTextCompare)
                Letters = Len(ColoredText)

                With .Font
                    .Name = "Times New Roman"
                    .Size = 12
                    .Bold = True
                    .Color = vbBlack
                End With
                If Position > 0 Then
                    With .Characters(Start:=Position, Length:=Letters)
                        .Font.Color = vbRed
                        .Font.Name = "Arial"
                        .Font.Size = 11
                    End With
                End If
            End With
        Else
            SkipSheet = False
        End If
    Next WS
    MsgBox "Done."
End Sub

Thank you so much!! This worked perfectly!

 

[borkybork]

I'm a bit late to this one, but please try the following.

Option Explicit
Sub colorString()
    Dim i As Long, s As String
    Dim wb As Workbook, ws As Worksheet
    Dim c As Range
    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet
   
    s = ws.Range("A1").Text
    i = InStrRev(s, vbLf) + 1
    s = WorksheetFunction.Trim(Mid(s, i, 100))
   
    For Each ws In wb.Worksheets
        Set c = ws.Range("A1")
        With Range("A1")
            For i = 1 To Len(c) - Len(s) + 1
                If Mid(c, i, Len(s)) = s Then
                    c.Characters(i, Len(s)).Font.Color = vbRed
                End If
            Next i
        End With
    Next ws

End Sub

Thank you!! Your code also worked, although it didn't do it for all the worksheets for some reason. Still appreciate your help though!!

 

[kevin9999]

Thank you!! Your code also worked, although it didn't do it for all the worksheets for some reason. Still appreciate your help though!!

Strange, it worked for me. Still, thanks for the feedback.