Option Explicit
'====================================================================================================
' найти и запустить макросы с листа можно, нажав Alt+ F8
' матчасть по словарям: http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/ischerpyvajushhee_opisanie_obekta_dictionary/7-1-0-101
'====================================================================================================
Sub ChangeKeysByValues() ' заменить КЛЮЧИ соответствующими ЗНАЧЕНИЯМИ
Dim dic As New Dictionary   ' раннее связывание - прямое подключение словаря для скорости, удобства и точности. Если надо позднее связывание, то замените на Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim ar As Range
Dim arrK, arrV, arrOne(1 To 1, 1 To 1)
Dim t!, r&, c&, n&, AC&

t = Timer                                           ' засекаем время
arrK = Worksheets("тут ищем").Range("D4:D8").Value  ' берём в массив диапазон КЛЮЧЕЙ с листа
arrV = Worksheets("тут ищем").Range("B4:B8").Value  ' берём в массив диапазон соответствующих ключам ЗНАЧЕНИЙ с листа

For r = 1 To UBound(arrK, 1)                                            ' цикл по массивам с наполнением словаря
    If Not dic.Exists(arrK(r, 1)) Then dic.Add arrK(r, 1), arrV(r, 1)   ' если очередное значение из массива КЛЮЧЕЙ ещё не было добавлено, то добавляем пару КЛЮЧ-ЗНАЧЕНИЕ из двух массивов
Next r
arrV = 0                                                                ' очищаем переменную с массивом значений

Application.ScreenUpdating = False                                          ' отключаем обновление экрана
AC = Application.Calculation: Application.Calculation = xlCalculationManual ' запоминаем, какой пересчёт установлен в книге и стаавим ручной

For Each ar In Range("_insert")                                     ' цикл по всем областям диапазона вставки (именованный диапазон "_insert")
    arrK = ar.Value                                                 ' забираем область в массив
    If Not IsArray(arrK) Then arrOne(1, 1) = arrK: arrK = arrOne    ' если получили нНЕ массив, значит область состояла из одной ячейки. Преобразуем это значение в двумерный массив

    For c = 1 To UBound(arrK, 2)                                    ' цикл по столбцам массива
        For r = 1 To UBound(arrK, 1)                                ' цикл по строкам массива
            If dic.Exists(arrK(r, c)) Then                      ' если очередное значение массива ЕСТЬ в словаре в качестве КЛЮЧА …
                n = n + 1: arrK(r, c) = dic(arrK(r, c))             ' увеличиваем счётчик найденных ключей и заменяем этот КЛЮЧ на соответствующее ему ЗНАЧЕНИЕ
            Else                                                ' если такого ключа НЕТ …
                arrK(r, c) = "!!! NO KEY > " & arrK(r, c)       ' добавляем к значению префикс для удобства поиска
            End If
        Next r
    Next c

    ar.Value = arrK
Next ar

Application.ScreenUpdating = True: Application.Calculation = AC ' включаем обновление экрана и восстанавливаем пересчёт
MsgBox "Was inserted Values by Keys: " & Format$(n, "#,##0") & " out of " & Format$(Range("_insert").Cells.Count, "#,##0"), vbInformation, Format$(Timer - t, "0.00 sec")
End Sub
'====================================================================================================
Sub CheckKeys() ' проверить КЛЮЧИ по списку
Dim dic As New Dictionary
Dim ar As Range
Dim arrK, arrOne(1 To 1, 1 To 1)
Dim t!, r&, c&, n&, AC&, fAr As Boolean

t = Timer
arrK = Worksheets("тут ищем").Range("D4:D8").Value  ' берём в массив диапазон КЛЮЧЕЙ с листа

For r = 1 To UBound(arrK, 1)
    If Not dic.Exists(arrK(r, 1)) Then dic.Add arrK(r, 1), 0    ' наполняем словарь КЛЮЧАМИ
Next r

Application.ScreenUpdating = False
AC = Application.Calculation: Application.Calculation = xlCalculationManual

For Each ar In Range("_insert") ' вместо именованного диапазона (можно посмотреть в диспетчере имён Ctrl+F3) «_insert» можно использовать произвольный, например «Range("A1:B20")» - для проверки ключей в диапазоне A1:B20 того листа, с которого был запущен макрос или «Worksheets("имя нужного листа").Range("A1:B20")» - для указания конкретного листа
    arrK = ar.Value
    If Not IsArray(arrK) Then arrOne(1, 1) = arrK: arrK = arrOne

    For c = 1 To UBound(arrK, 2)
        For r = 1 To UBound(arrK, 1)
            If Not dic.Exists(arrK(r, c)) Then          ' если ключа нет в словаре …
                fAr = True: n = n + 1                       ' ставим флаг вставки области (т.к. как минимум одна ячейка из области будет изменена) и увеличиваем счётчик НЕНАЙДЕННЫХ ЯЧЕЕК (НЕ путать с НЕНАЙДЕННЫМИ КЛЮЧАМИ, которых может быть меньше из-за повторов)
                arrK(r, c) = "!!! NO KEY > " & arrK(r, c)
            End If
        Next r
    Next c

    If fAr Then fAr = False: ar.Value = arrK            ' если флаг был установлен, то сбрасываем его и вставляем массив обратно в область
Next ar

Application.ScreenUpdating = True: Application.Calculation = AC ' включаем обновление экрана и восстанавливаем пересчёт

r = Range("_insert").Cells.Count    ' запоминаем в переменную общее количество проверяемых ячеек (ключей)
If n = 0 Then MsgBox "All Cells (" & Format$(r, "#,##0") & ") was FOUND!", vbInformation, Format$(Timer - t, "0.00 sec"): Exit Sub
MsgBox "Find Cells: " & Format$(r - n, "#,##0") & " out of " & Format$(r, "#,##0"), vbInformation, Format$(Timer - t, "0.00 sec")
End Sub
'====================================================================================================

Dim rng As Range

With Sheets("Номенклатура WB")
     arrK = .Range("I1:I" & .Cells(.Rows.Count, "I").End(xlUp).Row).Value
End With

With Sheets("Сводные данные")
    Set rng = .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
End With

For Each ar In rng
…