VBA to change color of partial text

B

borkybork

New Member
Joined
Aug 5, 2022
Messages
18
Office Version
  1. 365
Platform
  1. Windows
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:
excel default.png


format needed:
excel desired output.png


VBA Code: 
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
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
It might be better if you searched for the text you want to change the color of instead of the line feed character.

VBA Code: 
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
 
Upvote 0
rlv01 said:
It might be better if you searched for the text you want to change the color of instead of the line feed character.

VBA Code: 
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
Click to expand...
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.
 
Upvote 0
VBA Code: 
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
 
Upvote 0
Solution
I'm a bit late to this one, but please try the following.

VBA Code: 
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
 
Upvote 0
rlv01 said:
VBA Code: 
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
Click to expand...
Thank you so much!! This worked perfectly!
 
Upvote 0
kevin9999 said:
I'm a bit late to this one, but please try the following.

VBA Code: 
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
Click to expand...
Thank you!! Your code also worked, although it didn't do it for all the worksheets for some reason. Still appreciate your help though!!
 
Upvote 0
borkybork said:
Thank you!! Your code also worked, although it didn't do it for all the worksheets for some reason. Still appreciate your help though!!
Click to expand...
Strange, it worked for me. Still, thanks for the feedback.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Write formula to compare planned amounts by vendor in one sheet to approved amounts by vendor in another tab based on project ID
Replies
1
Views
335
OaklandJim
O
S
  • Question
Linking workbooks with changing names
Replies
6
Views
258
Shortmeister1
S
A
  • Solved
Comparing two excel files for matching / mismatching rows (long text strings - match() wont work
Replies
4
Views
553
ahaye
A
S
  • Solved
VBA Code to select a variable folder path, find multiple .xls then copy same named worksheets into new workbook.
Replies
4
Views
433
SteveD01
S
A
  • Question
VBA - Copying Worksheets that contain Pivot tables
Replies
1
Views
615
Alex Blakenburg
A

Forum statistics

Threads
1,214,834
Messages
6,121,877
Members
449,056
Latest member
ruhulaminappu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top