Изменение цвета ячейки согласно словарю

[nifra]

Здравствуйте уважаемые.
Прошу помощи.
имею вот такой макрос.
Нужно чтобы в одной ячейке согласно словарю выделялись цветом определенные слова. Это все работает. Но, если у меня в одной ячейке одно и тоже слово повторяется несколько раз, то выделяется только первое, а остальные нет.
Возможно ли сделать так, чтобы выделялись все одинаковые слова в одной ячейке.

Option Explicit
Option Compare Text

Sub ЭТОТ_МАКРОС_НУЖНО_ЗАПУСКАТЬ()
Application.ScreenUpdating = False
    Dim iStart As Integer
    Dim rng As Range, cell As Range, sSearchString As String, lastRow&, i&, color&
    
    Set rng = Selection
    
lastRow = Sheets("словарь").[a1000].End(xlUp).Row

For i = 1 To lastRow
If Sheets("словарь").Range("A" & i).Font.ColorIndex <> xlAutomatic Then
    color = Sheets("словарь").Range("A" & i).Font.color
Else
    color = -65536
End If
    sSearchString = Sheets("словарь").Range("A" & i).Value

    For Each cell In rng
        If cell Like "*" & sSearchString & "*" Then
            iStart = InStr(cell.Value, sSearchString)
            With cell.Characters(Start:=iStart, Length:=Len(sSearchString)).Font
                .Bold = True
                .color = color
            End With
        End If
    Next
Next
Application.ScreenUpdating = True
End Sub

заранее спасибо

[Hugo121]

Есть мысль запустить поиск iStart в цикле - но нет подопытного файла...

[nifra]

Добавил файл в шапку,
при нажатии на картинку происходит макрос

[Hugo121]

В 2003 Ваш файл не открывается.

[nifra]

у меня excel 2013, при сохранении файла в 2003 не вижу, чтоб была поддержка макросов. как быть?

[kalbasiatka]

В 2003 макросы по умолчанию поддерживаются.

[nifra]

вот 2003 выкладываю

[Hugo121]

И точно Loop достаточно (и одной доппроверки):

Option Explicit
Option Compare Text

Sub ЭТОТ_МАКРОС_НУЖНО_ЗАПУСКАТЬ()
    Application.ScreenUpdating = False
    Dim iStart As Integer
    Dim rng As Range, cell As Range, sSearchString As String, lastRow&, i&, color&

    Set rng = Selection

    lastRow = Sheets("словарь").[a1000].End(xlUp).Row

    For i = 1 To lastRow
        If Sheets("словарь").Range("A" & i).Font.ColorIndex <> xlAutomatic Then
            color = Sheets("словарь").Range("A" & i).Font.color
        Else
            color = -65536
        End If
        sSearchString = Sheets("словарь").Range("A" & i).Value

        For Each cell In rng
            If cell Like "*" & sSearchString & "*" Then
                Do
                    iStart = InStr(iStart + 1, cell.Value, sSearchString)
                    If iStart Then
                        With cell.Characters(Start:=iStart, Length:=Len(sSearchString)).Font
                            .Bold = True
                            .color = color
                        End With
                    End If
                Loop While iStart
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

[nifra]

Hugo121, огроменное Вам спасибо и низкий поклон!!!