Option Explicit

Sub MyItemMarker()

'Создаём и Наполняем Словари----------------------------------------------------

'Объявляем переменные для словарей Маркеров
Dim DictType
Dim DictBrand
Dim DictColor

Dim row As Integer ' Создаём переменную счетчик строк
Dim key As String, item As String ' Создаём переменные для Ключа и Элемента словарей

    'Создаём словари
    Set DictType = CreateObject("Scripting.Dictionary")
    Set DictBrand = CreateObject("Scripting.Dictionary")
    Set DictColor = CreateObject("Scripting.Dictionary")
    
    ' Наполняем словари из диапазона
    With Sheets("test_data").Range("D3:E5") ' Словарь DictType
        For row = 1 To .Rows.Count
            key = CStr(.Cells(row, 1).Value) ' Получаем Key - ключ
            item = CStr(.Cells(row, 2).Value) ' Получаем Item - значение
            DictType.Add key, item ' Добавляем новую пару в Словарь
        Next row
    End With

    With Sheets("test_data").Range("F3:G7") 'Словарь DictBrand
        For row = 1 To .Rows.Count
            key = CStr(.Cells(row, 1).Value) ' Получаем Key - ключ
            item = CStr(.Cells(row, 2).Value) ' Получаем Item - значение
            DictBrand.Add key, item ' Добавляем новую пару в Словарь
        Next row
    End With
    
    With Sheets("test_data").Range("H3:I7") 'Словарь DictColor
        For row = 1 To .Rows.Count
            key = CStr(.Cells(row, 1).Value) ' Получаем Key - ключ
            item = CStr(.Cells(row, 2).Value) ' Получаем Item - значение
            DictColor.Add key, item ' Добавляем новую пару в Словарь
        Next row
    End With

'Создаём и Наполняем Результирующий Массив---------------------------------------------

Dim ArrTmp As Variant ' Временный массив
    With Sheets("test_data").Range("A3", Cells(Rows.Count, 1).End(xlUp))
        ArrTmp = WorksheetFunction.Transpose(.Value) ' Наполняем временный одномерный массив из диапазона
    End With

    Dim ArrResult() ' Результирующий массив
        ReDim ArrResult(0 To UBound(ArrTmp, 1) - 1, 0 To 3) As Variant

Dim n As Long, k As Long, d As Long, sStr As String

    ' Переносим в массив ArrResult Наменклатуру из временного массива ArrTmp
    For n = LBound(ArrResult, 1) To UBound(ArrResult, 1)
        k = n + 1
        ArrResult(n, 0) = ArrTmp(k)
    Next n
    
    ' Заполняем массив ArrResult маркерами по Словарям
    ' Парсим каждый первый элемент второго уровня в массиве ArrResult
    For n = LBound(ArrResult, 1) To UBound(ArrResult, 1)
        
        ' Проставляем маркер Типа намеклатуры по словарю DictType
        For d = 0 To DictType.Count - 1
            key = DictType.Keys()(d)
            item = DictType.Items()(d)
            sStr = ArrResult(n, 0)
            
            If InStr(1, sStr, key, vbTextCompare) > 0 Then
                ArrResult(n, 1) = item
            End If
        Next d
        
        ' Проставляем маркер Бренда намеклатуры по словарю DictBrand
        For d = 0 To DictBrand.Count - 1
            key = DictBrand.Keys()(d)
            item = DictBrand.Items()(d)
            sStr = ArrResult(n, 0)
            
            If InStr(1, sStr, key, vbTextCompare) > 0 Then
                ArrResult(n, 2) = item
            End If
        Next d
        
        ' Проставляем маркер Цвета намеклатуры по словарю DictColor
        For d = 0 To DictColor.Count - 1
            key = DictColor.Keys()(d)
            item = DictColor.Items()(d)
            sStr = ArrResult(n, 0)
            
            If InStr(1, sStr, key, vbTextCompare) > 0 Then
                ArrResult(n, 3) = item
            End If
        Next d
    Next n

Stop ' Остановка по требыванию:)))

End Sub

    For n = LBound(ArrResult, 1) To UBound(ArrResult, 1)
        k = n + 1
        ArrResult(n, 0) = ArrTmp(k)
    Next n

    For n = LBound(ArrResult, 1) To UBound(ArrResult, 1)
        ArrResult(n, 0) = ArrTmp(n+1)
    Next n

Option Explicit
Sub MyItemMarker1()
Dim DictType()
Dim n&, k As Byte, i As Byte
Dim ArrResult()
DictType = Application.Transpose(Sheets("test_data").Range("D3:F7").Value)
ArrResult() = Sheets("test_data").Range("A3", Sheets("test_data").Cells(Rows.Count, 1).End(xlUp)).Value
ReDim Preserve ArrResult(1 To UBound(ArrResult), 1 To 4)
For n = LBound(ArrResult, 1) To UBound(ArrResult, 1)
   For k = LBound(DictType, 1) To UBound(DictType, 1)
        For i = LBound(DictType, 2) To UBound(DictType, 2)
            If Not IsEmpty(DictType(k, i)) Then
                If InStr(1, ArrResult(n, 1), DictType(k, i), vbTextCompare) > 0 Then ArrResult(n, k + 1) = DictType(k, i)
            End If
 Next i, k, n
Stop
End Sub

Rows.Count

MyArray(1,2) = DicObj.Item(Cstr(MyArray(1,1))