Сравнение текстовой строки с заданным словарём

Sub tm()
Application.ScreenUpdating = False
a = "ФрутоНяня"
For i = 2 To 689 'строки
If InStr(1, Cells(i, 1).Value, a) <> 0 Then
Cells(i, 6).Value = a
 
End If
Next
Application.ScreenUpdating = True
End Sub

   ' Чтение эталонов в словарь
   Application.StatusBar = "Чтение эталонов"
   Set dicEtal = CreateObject("Scripting.Dictionary")
   With ThisWorkbook.Sheets(shEtal)    ' сохранить необходимые эталоны в словарь
      iLastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      For i = 2 To iLastRow
         xStr = CStr(.Cells(i, "B").Value)   ' значение - важно взять так!
         If xStr <> "" Then If Not dicEtal.Exists(xStr) Then dicEtal.Add xStr, CStr(.Cells(i, "A").Value) ' key, item
      Next
   End With

If dicEtal.Exists(xStr) Then xStr = dicEtal.Item(xStr)   ' замена по словарю

Sub tm()
a = Array("ФрутоНяня", "коблево", "шнобелево")
Application.ScreenUpdating = False
    For i = LBound(a) To UBound(a)
        For j = 2 To 689 'строки
            If InStr(Cells(j, 1).Value, a(i)) <> 0 Then
                Cells(j, 6).Value = a(i)
                Exit For
            End If
        Next j
    Next i
Application.ScreenUpdating = True
End Sub

Sub tm()
a = Array("Gala", "LekoPro", "1000 секретов", "21 канал", "32 Перлини Kids", "4MOVE", "7 day's", "7UP", "7я", "Absolut", "Active", "Activex", "ACTIVUS", "ADMIRALSKA", "Agrola", "Ahmad tea", "Air Wick", "Airwaves", "AL Capone", "Albatros", "ALBERTO", "Aleo", "ALEXANDRION", "Alexis", "Alexx", "Allatini", "Alles GUT!", "Almond", "Alokozay", "Always", "Ambassador", "Ani", "Anri", "Aperitivo", "APEROL", "Apostrophe", "APPS", "AQUA ZENI", "Aquafresh", "Aquarte", "ARAZANI", "Ariel", "Aris", "Arko", "ARMAVENI", "ARMEN BAGRANYAN", "Arrighi", "ARTWINE", "Artwinery", "Askold", "Astafian", "Attuale", "Axe", "Azercay")
Application.ScreenUpdating = False
For i = LBound(a) To UBound(a)
For j = 2 To 689 'строки
If Cells(j, 2) Like a(i) Then
Cells(j, 6).Value = a(i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

If Cells(j, 2) Like "* " & a(i) & " *" or _
If Cells(j, 2) Like "*" & a(i) & " *" or _
If Cells(j, 2) Like "* " & a(i) & "*"  Then

Sub tm()
    a = Array("Gala", "LekoPro", "1000 секретов", "21 канал", "32 Перлини Kids", "4MOVE", "7 day's", "7UP", "7я", "Absolut", "Active", "Activex", "ACTIVUS", "ADMIRALSKA", "Agrola", "Ahmad tea", "Air Wick", "Airwaves", "AL Capone", "Albatros", "ALBERTO", "Aleo", "ALEXANDRION", "Alexis", "Alexx", "Allatini", "Alles GUT!", "Almond", "Alokozay", "Always", "Ambassador", "Ani", "Anri", "Aperitivo", "APEROL", "Apostrophe", "APPS", "AQUA ZENI", "Aquafresh", "Aquarte", "ARAZANI", "Ariel", "Aris", "Arko", "ARMAVENI", "ARMEN BAGRANYAN", "Arrighi", "ARTWINE", "Artwinery", "Askold", "Astafian", "Attuale", "Axe", "Azercay")
    Application.ScreenUpdating = False
    Dim MySTR As String
    For i = 2 To Range("B2").End(xlDown).Row 'строки
        MySTR = Trim(LCase(Cells(i, 2)))     ' чтоб лишний раз не обращаться к ячейкам, запоминаем значение ячейки в переменную
        For j = LBound(a) To UBound(a)  ' элементы массива
            If MySTR Like "*" & LCase(Trim(a(j))) & "*" Then
                Cells(i, 6).Value = a(j)
                GoTo n ' Если нашли искомое, зачем продолжать просмотр массива? Переходим к следующей ячейке!
            End If
        Next j
n:
    Next i
    Application.ScreenUpdating = True
End Sub

Sub Zeag()
Dim L As Long, J As Long
Dim indexesArr(1 To 5) As Long
indexesArr(1) = 1
indexesArr(2) = 3
indexesArr(3) = 4
indexesArr(4) = 5
indexesArr(5) = 11
' Здесь лежат удобные номера столбцов
 
Dim myArr(1 To 5)
myArr(1) = Range(Cells(2, 1), Cells(Cells(2, 1).End(xlDown).Row, 1)).Value    ' A
myArr(2) = Range(Cells(2, 3), Cells(Cells(2, 3).End(xlDown).Row, 3)).Value    ' C
myArr(3) = Range(Cells(2, 4), Cells(Cells(2, 4).End(xlDown).Row, 4)).Value    ' D
myArr(4) = Range(Cells(2, 5), Cells(Cells(2, 5).End(xlDown).Row, 5)).Value    ' E
myArr(5) = Range(Cells(2, 11), Cells(Cells(2, 11).End(xlDown).Row, 11)).Value ' K
' Получен массив массивов, это одномерный массив из пяти элементов, _
каждый элемент массива - двумерный массив. _
В двумерном массиве значения ячеек соответствующего столбца. _
Получение этого массива значений очень быстрое и обработка их с коде - тоже. _
Нет необходимости в отключении отрисовки через (ScreenUpdate = false)
 
' Пять строк с "myArr(1) = ..." писал для наглядности и понимания, можно было упихать в цикл...
 
' Вот пример прохода в цикле по такому массиву двумерных массивов
 
For J = LBound(myArr) To UBound(myArr) ' Проход по пяти "Столбцам" - элементам массива массивов
    For L = LBound(myArr(J)) To UBound(myArr(J)) ' В двумерном массиве по всем элементам
        If myArr(J)(L, 1) = 0 Then myArr(J)(L, 1) = 1 ' "L, 1" - Важно помнить, что когда массив получен из ячеек, то это ВСЕГДА двумерный массив и обращение к нему с указанием строки, затем столбца
    Next L
Next J
 
' Теперь выгрузка обратно в ячейки
 
For L = LBound(myArr) To UBound(myArr)
    Range(Cells(2, indexesArr(L)), Cells(UBound(myArr(L)), indexesArr(L))).Value = myArr(L)
Next    ' Какбэ всё
End Sub