Оптимизировать код - VBA (250579)

Формулировка задачи:

Добрый день всем. Очень нужна помощь, не смог найти на форуме подсказок. Есть макрос для поиска значений. Цель макроса найти строки с одиноковой площадкой. И если хотя бы в одной строке есть "ETH" в столбце F то записать во всех строках этой площадки, в яйчейке J "да". Если не находит то записать "нет". Все бы ничего но список строк очень большой и эксель в итоге виснет. Если кто может, помогите разобраться. Спасибо всем. Вот собственно сам макрос:

Dim i As Long, j As Long, ID_Element As Boolean, count(1 To 50) As Integer
 
Sub Searching()
Application.ScreenUpdating = False
 
For i = 2 To ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
m = 1
Application.StatusBar = i & " OF " & ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
    For j = 2 To ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
        If ActiveSheet.Cells(j, "C").Value Like ActiveSheet.Cells(i, "C").Value Then
            count(m) = j
            m = m + 1
            If ActiveSheet.Cells(j, "F").Value Like "*ETH*" Then ID_Element = True

        End If
    Next j
 
If ID_Element = True Then
For j = 1 To m - 1
ActiveSheet.Cells(count(j), "J").Value = "Yes"
Next j
End If
 
ID_Element = False
Next i
 
For i = 2 To ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
If Not ActiveSheet.Cells(i, "J").Value Like "*Yes*" Then ActiveSheet.Cells(i, "J").Value = "No"
Next i
 
Application.ScreenUpdating = True
End Sub

Решение задачи: «Оптимизировать код»

textual
                            Листинг программы 
                        

                            Sub Searching1()
    Dim a, i&
    a = ActiveSheet.UsedRange
    b = ActiveSheet.UsedRange.Columns(10)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a)
            If InStr(1, a(i, 6), "ETH") <> 0 Then .Item(a(i, 2)) = 1
        Next i
        For i = 2 To UBound(a)
            b(i, 1) = IIf(.exists(a(i, 2)), "Yes", "No")
        Next i
    End With
    Cells(1, 10).Resize(UBound(b)) = b
End Sub
                        