Excel Split out Array for Different Colours - arrays

Question

I had help with this code below, that works like a dream, it finds words from all 5 search textboxes and highlights them in red and adds a count to one of the columns. However i want to do the same but for box 1 word is in red and box 2 the word it finds it highlights in green and box 3 in orange etc etc. Is it possible to split out from the array which text box goes to which section of code, then could I change the second full set of loops to look for the word n the second textbox and make the word green?
I hope that makes sense?
Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
mywords = Array(UsrFormSearch.TxtSearch1.Value, UsrFormSearch.TxtSearch2.Value,
UsrFormSearch.TxtSearch3.Value, UsrFormSearch.TxtSearch4.Value, UsrFormSearch.TxtSearch5.Value)
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
For m = 0 To UBound(mywords)
With ActiveSheet.Range("B2:E4000")
Set c = .Find(mywords(m), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For i = 1 To Len(c.Value)
sPos = InStr(i, c.Value, mywords(m))
sLen = Len(mywords(m))
If (sPos <> 0) Then
c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(mywords(m)) - 1
CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1,
1).Row + 1, 1) + 1
End If
Next i
Set c = .FindNext(c)
If firstAddress = c.Address Then Exit Do
Loop While Not c Is Nothing
End If
End With
Next m
SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray

Answer 1

Something like this would work. Just add in a second array of your RGB values which you can reference during each loop cycle.
Sub TestColor()
Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant, myColors As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
With UsrFormSearch ' Think the .Value is superfluous - add back in if issues arise
mywords = Array(.TxtSearch1, .TxtSearch2, .TxtSearch3, .TxtSearch4, .TxtSearch5)
End With
myColors = Array(RGB(255, 0, 0), RGB(0, 255, 0), RGB(255, 255, 0), RGB(255, 0, 255), RGB(0, 0, 255))
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
For m = 0 To UBound(mywords)
With ActiveSheet.Range("B2:E4000")
Set c = .Find(mywords(m), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For i = 1 To Len(c.Value)
sPos = InStr(i, c.Value, mywords(m))
sLen = Len(mywords(m))
If (sPos <> 0) Then
c.Characters(Start:=sPos, Length:=sLen).Font.Color = myColors(m)
c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(mywords(m)) - 1
CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) + 1
End If
Next i
Set c = .FindNext(c)
If firstAddress = c.Address Then Exit Do
Loop While Not c Is Nothing
End If
End With
Next m
SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray
End Sub