Excel разделить массив для разных цветов

Question

Мне помогли приведенные ниже коды, которые работают как во сне: они находят слова во всех 5 текстовых полях поиска, выделяют их красным цветом и добавляют счетчик в один из столбцов. Однако я хочу сделать то же самое, но в поле 1 слово выделено красным цветом, а в поле 2 слово, которое оно находит, выделяется зеленым, а поле 3 - оранжевым et c et c. Можно ли выделить из массива, какое текстовое поле переходит в какой раздел кода, тогда можно ли изменить второй полный набор циклов, чтобы искать слово n во втором текстовом поле и сделать слово зеленым?

Надеюсь, в этом есть смысл?

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

Что-то вроде этого могло бы работать. Просто добавьте второй массив ваших значений RGB, на которые вы можете ссылаться в течение каждого цикла l oop.

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