=ЕСЛИ(СЧЁТ(ПОИСК(Лист2!A$1:A$234;B2));"директ";C2)

Sub tt()
    With Sheets("Лист2")
        n_ = .Cells(.Rows.Count, 1).End(3).Row
        ar = .Cells(1).Resize(.Cells(.Rows.Count, 1).End(3).Row)
    End With
    d_ = "Директ"
    n1_ = Cells(Rows.Count, 2).End(3).Row - 1
    ar1 = Cells(2, 2).Resize(n1_)
    ar2 = Cells(2, 3).Resize(n1_)
    With CreateObject("Scripting.Dictionary")
    'словарь нужен, чтобы убрать множественные дубликаты в листе2. Можно без этого, но на больших объемах лучше без дублей
    'можно было удалить дубли сразу на листе 2, но можно ли там что-то менять? Не знаю
        For r = 1 To n_
            a = .Item(ar(r, 1))
        Next r
        nn_ = .Count - 1
        For i = 1 To n1_
            For j = 0 To nn_
                If ar2(i, 1) <> d_ Then
                    If InStr(ar1(i, 1), .keys()(j)) Then
                        ar2(i, 1) = d_
                    End If
                End If
            Next j
        Next i
    End With
    Cells(2, 3).Resize(n1_) = ar2
End Sub