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

Мне помогли приведенный ниже код, который работает как сон, он находит слова из всех 5 текстовых полей поиска, выделяет их красным и добавляет счетчик в один из столбцов. Однако я хочу сделать то же самое, но для поля 1 слово выделено красным цветом, а поле 2 - слово, которое оно находит, выделяется зеленым, а поле 3 - оранжевым и т.д. кода, то могу ли я изменить второй полный набор циклов, чтобы искать слово 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
# excel arrays
Источник
  • 0
    Мне нужно проверить это после обеда, поэтому я пока не буду ставить это в качестве ответа, но вы, вероятно, можете установить свои параметры RGB как переменные, например: R as long , G as Long т. Д., И изменять R, G и B в каждом цикле (добавить определенный количество или исправить в функции значения цикла m
Codelisting
за 3 против
Лучший ответ

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

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
  • 0
    Привет, извините, я был заблокирован из-за covid, это абсолютно идеально, то, что я написал, циклически перебиралось каждый раз для каждого слова в поиске и длилось вечно. Могу ли я открыть еще одну заявку на другой вопрос? Вопрос в том, что я установил добавление 1 значения в последний столбец для каждого найденного слова, но если вы хотите добавить значение 1 для textbox1search и 2 для textbox2search и так далее. Будет ли мне лучше выполнять цикл каждый раз, или это также можно сделать, добавив массив со значением и связав его с существующей процедурой. Большое спасибо. VBVirg
Codelisting
Популярные категории
На заметку программисту