Find strings from arrays and set text colour

[Dave_P_C]

I have a number of cells (D4:D39) containing event descriptions followed by 3 digit codes and I want to colour these codes differently depending on which group they belong to

	D
4	ALL Groups ABC - DEF - PQR - VWX - 21E - XY2
5	GROUPS2 and 3 MNO - STU - A1C - XY2
6	GROUP1, 2 and 4 GHI - PQR - 12D - 45S - 61D
...

<tbody>
</tbody>

For example
Group1 consists of ABC, DEF, GHI, JKL - I want to colour these individual strings GREEN when they are present
Group2 consists of MNO, PQR, STU - I want to colour these individual strings RED when they are present
Group3 consists of VWX, YZ1, XY2, A1C - I want to colour these individual strings BLUE when they are present
Group4 consists of 12D, 21E, 34D, 45S, 61D - I want to colour these individual strings ORANGE when they are present


I have found the ColorMyWord() VBA script which can achieve this but it uses CASE statements so I would need to write around 80 CASE seperate case statements to cover all of the different 3 digit codes.

Option Explicit
Sub ColorMyWord()


Dim startChar As Integer, _
    lenColor As Integer, _
    nxtWord As Integer
Dim w As Range, _
    myRange As Range
Dim dRed As Integer, _
    dBlue As Integer, _
    dGreen As Integer
Dim firstAddress As String, _
    srchWord As String


Set myRange = Sheets("Events").Range("D4:D39")


'Reset all colors in D4:D39
    myRange.Font.ColorIndex = xlAutomatic


'Loop through 6 Cases, setting search word and RGB color codes
    For nxtWord = 1 To 6
      Select Case nxtWord
        Case 1
          srchWord = "VWX"
           dRed = 0
           dBlue = 112
           dGreen = 192 'Blue
        Case 2
          srchWord = "ABC"
           dRed = 0
           dBlue = 176
           dGreen = 80 'Green
        Case 3
          srchWord = "12D"
           dRed = 237
           dBlue = 125
           dGreen = 49 'Orange
        Case 4
          srchWord = "MNO"
           dRed = 255
           dBlue = 0
           dGreen = 0 'FF0000 Red
      End Select


'Find search words and set font color
      With myRange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
    Next
End Sub

Can this code be re-written so the 3 digit codes to search for are given in arrays (such as below)?


Array1 "ABC", "DEF", "GHI", "JKL"
Array2 "MNO", "PQR", "STU"
Array3 "VWX", "YZ1", "XY2", "A1C"
Array4 "12D", "21E", "34D", "45S", "61D"

 

[offthelip]

This code will do it for you. I have defined an array with all the search strings and the associated colours in it. The easy way to do this is to use a "control" worksheet. If you don't want to do that you can define it in VBA. I have assumed the list to be formatted is in a worksheet called test
the code is:

Sub coltest()
Dim w As Range
Dim Txt As String


With Worksheets("Control")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
colorArray = Range(.Cells(1, 1), .Cells(lastrow, 9))
End With
Worksheets("Test").Select
lastrowD = Cells(Rows.Count, "D").End(xlUp).Row
inarr = Range(Cells(1, 4), Cells(lastrowD, 4))
For i = 1 To lastrowD
   For j = 1 To 6
    For k = 2 To lastrow
    Txt = inarr(i, 1)
      startChar = InStr(1, Txt, colorArray(k, j), vbTextCompare)
      If startChar <> 0 And colorArray(k, j) <> "" Then
       Set w = Range(Cells(i, 4), Cells(i, 4))
        Dred = colorArray(k, 7)
        DBlue = colorArray(k, 8)
        DGreen = colorArray(k, 9)
        lencolor = Len(colorArray(k, j))
        w.Characters(Start:=startChar, Length:=lencolor).Font.Color = _
        RGB(Dred, DBlue, DGreen)
      End If
   Next k
  Next j
Next i


End Sub

The worksheet "control" data is in columms A to I (Dred is G, Dblue is H and Dgreen is I
Blank cells in columns A to F are ignored.

						dRed	dBlue	Dgreen
ABC	DEF	GHI	JKL			0	112	192
MNO	PQR	STU				0	176	80
VWX	YZ1	XY2	A1C			237	125	49
12D	21E	34D	45S	61D		255	0	0

<tbody>
</tbody>

 

[NdNoviceHlp]

I didn't know that it was possible even probable that XL would let U change the color of individual characters within a cell...cool. Anyways, here's some code. HTH. Dave

Option Explicit
Sub ColorMyWord()
Dim Lastrow As Integer, Rng As Range, Cnt As Integer, myrange2 As Range
Dim srchWord2 As String, dRed2 As Integer, dBlue2 As Integer, dGreen2 As Integer
Lastrow = Sheets("Events").Cells(Rows.Count, "D").End(xlUp).Row
Set myrange2 = Sheets("Events").Range("D4:D" & Lastrow)
'Reset all colors in D4:D39
myrange2.Font.ColorIndex = xlAutomatic
Lastrow = Sheets("Events").Cells(Rows.Count, "D").End(xlUp).Row
'loop "D"
For Cnt = 4 To Lastrow
Set Rng = Sheets("Events").Range("D" & Cnt)
If InStr(Sheets("Events").Range("D" & Cnt).Value, "VWX") Then
srchWord2 = "VWX"
dRed2 = 0
dBlue2 = 112
dGreen2 = 192 'Blue
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
If InStr(Sheets("Events").Range("D" & Cnt).Value, "ABC") Then
srchWord2 = "ABC"
dRed2 = 0
dBlue2 = 176
dGreen2 = 80 'Green
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
If InStr(Sheets("Events").Range("D" & Cnt).Value, "12D") Then
srchWord2 = "12D"
dRed2 = 237
dBlue2 = 125
dGreen2 = 49 'Orange
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
If InStr(Sheets("Events").Range("D" & Cnt).Value, "MNO") Then
srchWord2 = "MNO"
dRed2 = 255
dBlue2 = 0
dGreen2 = 0 'FF0000 Red
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
Next Cnt
       End Sub

Private Function ChangeFont(myrange As Range, srchWord As String, dRed As Integer, dBlue As Integer, dGreen As Integer)
Dim startChar As Integer, _
    lenColor As Integer, _
    nxtWord As Integer
Dim w As Range
Dim firstAddress As String
'Find search words and set font color
      With myrange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
End Function

 

[NdNoviceHlp]

On review my previous post didn't provide U with the array solution that U requested. Here it is. Happy New Year! Dave

Option Explicit
Sub ColorMyWord()
Dim Lastrow As Integer, Rng As Range, Cnt As Integer, myrange2 As Range, i As Integer
Dim srchWord2 As String, dRed2 As Integer, dBlue2 As Integer, dGreen2 As Integer
Dim GrnArr() As Variant, RedArr() As Variant, BluArr() As Variant, OrnArr() As Variant

Lastrow = Sheets("Events").Cells(Rows.Count, "D").End(xlUp).Row
Set myrange2 = Sheets("Events").Range("D4:D" & Lastrow)
'Reset all colors in D4:D39
myrange2.Font.ColorIndex = xlAutomatic
'set arrays
GrnArr = Array("ABC", "DEF", "GHI", "JKL") 'green
RedArr = Array("MNO", "PQR", "STU") 'red
BluArr = Array("VWX", "YZ1", "XY2", "A1C") 'blue
OrnArr = Array("12D", "21E", "34D", "45S", "61D") 'orange

'loop "D"
For Cnt = 4 To Lastrow
Set Rng = Sheets("Events").Range("D" & Cnt)

For i = LBound(BluArr) To UBound(BluArr)
If InStr(Sheets("Events").Range("D" & Cnt).Value, BluArr(i)) Then
srchWord2 = BluArr(i)
dRed2 = 0
dBlue2 = 112
dGreen2 = 192 'Blue
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
Next i
For i = LBound(GrnArr) To UBound(GrnArr)
If InStr(Sheets("Events").Range("D" & Cnt).Value, GrnArr(i)) Then
srchWord2 = GrnArr(i)
dRed2 = 0
dBlue2 = 176
dGreen2 = 80 'Green
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
Next i
For i = LBound(OrnArr) To UBound(OrnArr)
If InStr(Sheets("Events").Range("D" & Cnt).Value, OrnArr(i)) Then
srchWord2 = OrnArr(i)
dRed2 = 237
dBlue2 = 125
dGreen2 = 49 'Orange
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
Next i
For i = LBound(RedArr) To UBound(RedArr)
If InStr(Sheets("Events").Range("D" & Cnt).Value, RedArr(i)) Then
srchWord2 = RedArr(i)
dRed2 = 255
dBlue2 = 0
dGreen2 = 0 'FF0000 Red
Call ChangeFont(Rng, srchWord2, dRed2, dBlue2, dGreen2)
End If
Next i
Next Cnt
End Sub

Private Function ChangeFont(myrange As Range, srchWord As String, dRed As Integer, dBlue As Integer, dGreen As Integer)
Dim startChar As Integer, _
    lenColor As Integer, _
    nxtWord As Integer
Dim w As Range
Dim firstAddress As String
'Find search words and set font color
      With myrange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
End Function

 

[Dave_P_C]

Hi offthelip / NdNoviceHlp,

Thank you both for your responses.

Unfortunately the option of using a control sheet is not suitable for me in this situation.

Looking at both of your suggestions I have written the following code which works for me. I am not a coder so it may be possible to improve this and all suggestions are welcome but I'll past it below in case it helps others

Option Explicit
Sub ColorMyWord()


Dim startChar As Integer, _
    lenColor As Integer, _
    nxtWord As Integer
Dim w As Range, _
    myRange As Range, _
    Lastrow As Integer
Dim dRed As Integer, _
    dBlue As Integer, _
    dGreen As Integer
Dim firstAddress As String, _
    srchWord As String


Dim MyWordsArray1()    As Variant
Dim MyWordsArray2()    As Variant
Dim MyWordsArray3()    As Variant


Dim i As Integer, j As Variant


'set arrays
MyWordsArray1() = Array("ABC", "DEF", "GHI", "JKL")
MyWordsArray2() = Array("MNO", "PQR", "STU")
MyWordsArray3() = Array("VWX", "YZ1", "A1C")


Set myRange = Sheets("Events").Range("D4:D39")


'Reset all colors in D4:D39
    myRange.Font.ColorIndex = xlAutomatic


    For i = LBound(MyWordsArray1()) To UBound(MyWordsArray1())
    j = MyWordsArray1(i)
    dRed = 0
    dBlue = 176
    dGreen = 80 'Green
    srchWord = MyWordsArray1(i)
    'Find search words and set font color
      With myRange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
    Next i


    For i = LBound(MyWordsArray2()) To UBound(MyWordsArray2())
    j = MyWordsArray2(i)
    dRed = 255
    dBlue = 0
    dGreen = 0 'FF0000 Red
    srchWord = MyWordsArray2(i)
    'Find search words and set font color
      With myRange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
    Next i


    For i = LBound(MyWordsArray3()) To UBound(MyWordsArray3())
    j = MyWordsArray3(i)
    dRed = 0
    dBlue = 112
    dGreen = 192 'Blue
    srchWord = MyWordsArray3(i)
    'Find search words and set font color
      With myRange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
    Next i


End Sub

 

[NdNoviceHlp]

Thanks for posting your outcome. U have omitted the orange font requirements and your "j" variable is unnecessary. My code was looping every cell in the range whereas yours passes the whole range of cells for colouring...much more efficient. Anyways, I retooled my code based on that enlightenment. The use of the function is to prevent repetitive coding and make future code adjustments easier. HTH. Dave

Option Explicit
Sub ColorMyWord()
Dim MyRng As Range, Lastrow As Integer
Dim dRed2 As Integer, dBlue2 As Integer, dGreen2 As Integer
Dim srchWord2 As String, i As Integer
Dim MyWordsArray1()    As Variant
Dim MyWordsArray2()    As Variant
Dim MyWordsArray3()    As Variant
'set arrays
MyWordsArray1() = Array("ABC", "DEF", "GHI", "JKL")
MyWordsArray2() = Array("MNO", "PQR", "STU")
MyWordsArray3() = Array("VWX", "YZ1", "A1C")
Set MyRng = Sheets("Events").Range("D4:D39")
'Reset all colors in D4:D39
MyRng.Font.ColorIndex = xlAutomatic
For i = LBound(MyWordsArray1()) To UBound(MyWordsArray1())
dRed2 = 0
dBlue2 = 176
dGreen2 = 80 'Green
srchWord2 = MyWordsArray1(i)
Call ChangeFont(MyRng, srchWord2, dRed2, dBlue2, dGreen2)
Next i
For i = LBound(MyWordsArray2()) To UBound(MyWordsArray2())
dRed2 = 255
dBlue2 = 0
dGreen2 = 0 'FF0000 Red
srchWord2 = MyWordsArray2(i)
Call ChangeFont(MyRng, srchWord2, dRed2, dBlue2, dGreen2)
Next i
For i = LBound(MyWordsArray3()) To UBound(MyWordsArray3())
dRed2 = 0
dBlue2 = 112
dGreen2 = 192 'Blue
srchWord2 = MyWordsArray3(i)
Call ChangeFont(MyRng, srchWord2, dRed2, dBlue2, dGreen2)
Next i
End Sub
Private Function ChangeFont(myRange As Range, srchWord As String, dRed As Integer, dBlue As Integer, dGreen As Integer)
Dim startChar As Integer, _
    lenColor As Integer, _
    nxtWord As Integer
Dim w As Range
Dim firstAddress As String
'Find search words and set font color
      With myRange
        Set w = .Find(srchWord, lookat:=xlPart, MatchCase:=True)
         If Not w Is Nothing Then
           firstAddress = w.Address
          Do
           startChar = InStr(1, w, srchWord)
              lenColor = Len(srchWord)
              w.Characters(Start:=startChar, Length:=lenColor).Font.Color = _
                     RGB(dRed, dBlue, dGreen)
              Set w = .FindNext(w)
          Loop While Not w Is Nothing And w.Address <> firstAddress
         End If
      End With
End Function