Сравнение диапазонов с пометкой совпадений

[strannick]

Добрый день, уважаемые форумчане!
Тема вроде известная и понятная. Нужен Ваш совет и подсказка. Ситуация касается сравнения диапазона ячеек строки с аналогичным диапазоном таких строк и при совпадении пометить шрифт другим цветом. Решение есть, но на сегодняшний момент при большем объеме строк, с которыми идет сравнение занимает много времени. Попытался загнать в массивы и сравнивать их элементы:

Sub Массивы()
Dim sh As Worksheet, sh1 As Worksheet
Dim a(), b()
Dim k As Long, kk As Long

    Set sh = Sheets("База заказов")
    Set sh1 = Sheets("Заказы")
    
a = sh.Range("F2:K2").Value
b = sh1.Range("F2:K9").Value

For k = 1 To UBound(a)
For kk = 1 To UBound(b)
If a(k, 1) = b(kk, 1) Then 'вот подскажите как пометить шрифт a(k, 1).Font.Color = -4165632 ?
Next kk, k
End Sub

А совет вообще-то нужен в принципе. Правильно ли я делаю? Обработка заказов на листе База заказов идет построчно, там цикл, потому и сравнение ячеек этой строки с диапазоном. Тут я конечно упрощенный вариант привел (во вложении). Но суть именно такая. Может еще как-то ускорить данный процесс, выбрать другой путь? На листе Заказы в реале уже скопилось порядка 2000 строк и тормоз весьма ощутимый.
Заранее спасибо!

[Hugo121]

Цикл в цикле долго.
Конечно на массивах на порядок быстрее, чем на диапазонах, но всё равно в данном случае нерационально.
Делайте так - сперва одним проходом один массив в словарь, затем одним проходом по второму массиву по словарю получаете результат.
Т.е. проверяете есть/нет значение в словаре. Ищите примеры scripting.dictionary - их тут много было.
Ну а покраска - это уже отдельная песня. Можно сразу красить на листе, что долго. Можно ставить метки в третий массив, его выгружать на лист, затем с помощью всяких specialcells/columndifferences определять нужные диапазоны и красить сразу всю кучу... Делать лень. В принципе
Я бы не красил, а забивал в свободный столбец через массив например "IIIIIIIII" - и быстро, и почти как покрашено, и сортировать можно хоть в XL2000

P.S. Хотя на 2000 строк можно и сразу на листе красить - тормоз не заметите

[nilem]

если покрасить, то так

...
Set sh = Sheets("База заказов")
Set sh1 = Sheets("Заказы")
a = sh.Range("F2:K2").Value
b = sh1.Range("F1:K9").Value
For k = 1 To UBound(a)
    For kk = 2 To UBound(b)
        If a(k, 1) = b(kk, 1) Then sh1.Cells(kk, 6).Font.Color = -4165632
    Next kk
Next k
...

а если ускорить, см. пост выше

[staniiislav]

Сделано по совету Hugo121 (со своими корректировками))))
так вам подойдет?:

Option Explicit

Sub pokraska()
Dim a, b, c, i&, u
    a = Range("F1:K" & Cells(Rows.Count, 1).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a)
        .Item(a(i, 1)) = .Item(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6))
    Next i

    With Sheets("Заказы")
        b = .Range("F1:K" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
    End With
    ReDim c(1 To UBound(b), 1 To 1)
    For i = 2 To UBound(b)
    u = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 6)
        If .Exists(u) Then
            c(i, 1) = i
        Else
            c(i, 1) = Empty
        End If
    Next i
       
    With Sheets("Заказы")
        For i = 2 To UBound(c)
            If Not IsEmpty(c(i, 1)) Then
                .Range(.Cells(i, 1), .Cells(i, 11)).Interior.ColorIndex = 37
            End If
        Next i
    End With
End With
End Sub

[staniiislav]

забыл уточнит, запускать макрос с на активном листе (База заказов)

[Hugo121]

staniiislav, в общем нормально, но если делать так - то массив с() лишний. Можно ведь сразу

If .Exists(u) Then Sheets("Заказы").Range(Sheets("Зака зы").Cells(i, 1), Sheets("Заказы").Cells(i, 11)).Interior.ColorIndex = 37

Доп. массив я думал использовать так - заполнили как у Вас (только зачем Else c(i, 1) = Empty?), затем выгрузили в свободный столбец, далее с помощью specialcells сразу весь нужный диапазон одним махом покрасили, затем метки удалили (тоже одним движением).

[staniiislav]

хотя так будет быстрее:

Option Explicit

Sub pokraska()
Dim a, b, i&, n&, u
    a = Range("F1:K" & Cells(Rows.Count, 1).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a)
        .Item(a(i, 1)) = .Item(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6))
    Next i

    With Sheets("Заказы")
        a = .Range("F1:K" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
    End With
    ReDim b(1 To UBound(a))
    For i = 2 To UBound(a)
    u = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
        If .Exists(u) Then n = n + 1: b(n) = i
    Next i
         
    With Sheets("Заказы")
        For i = 1 To n
            .Range(.Cells(b(i), 1), .Cells(b(i), 11)).Interior.ColorIndex = 37
        Next i
    End With
End With
End Sub

[staniiislav]

Сообщение от Hugo121

staniiislav, в общем нормально, но если делать так - то массив с() лишний. Можно ведь сразу

If .Exists(u) Then Sheets("Заказы").Range(Sheets("Зака зы").Cells(i, 1), Sheets("Заказы").Cells(i, 11)).Interior.ColorIndex = 37

Доп. массив я думал использовать так - заполнили как у Вас (только зачем Else c(i, 1) = Empty?), затем выгрузили в свободный столбец, далее с помощью specialcells сразу весь нужный диапазон одним махом покрасили, затем метки удалили (тоже одним движением).

ну да))) , чет сразу не додумал ) ща поправим! СПАСИБО, а Empty так, чтобы было )))

добавлено позже:

тогда вообще так получается (как вы подправили):

Option Explicit

Sub pokraska()
Dim a, i&, u, sh As Worksheet
Set sh = Sheets("Заказы")
    a = Range("F1:K" & Cells(Rows.Count, 1).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a)
        .Item(a(i, 1)) = .Item(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6))
    Next i

    With Sheets("Заказы")
        a = .Range("F1:K" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
    End With
    For i = 2 To UBound(a)
    u = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
        If .Exists(u) Then sh.Range(sh.Cells(i, 1), sh.Cells(i, 11)).Interior.ColorIndex = 37
    Next i
End With
End Sub

хотя если будет очень большой диапазон, то долговато наверное будет красить... хотя проверять надо )))

[Hugo121]

В том то и дело - если красить нужно много, то именно на этом и будет основная потеря времени.
Поэтому всю эту операцию нужно постараться сделать за один приём.
Ну а если прогноз, что красить будем примерно 10 строк - то Ваш код уже нет смысла улучшать, разница в скорости будет не заметна.

Переменная u в общем тоже лишняя - т.к. используется всего 1 раз. Если использовать чаще (как я обычно использовал t) - тогда смысл есть, чтоб много раз не лезть в массив и не конкатенировать

[nilem]

один японский перец всегда вместо этого

.Item(a(i, 1)) = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)

пишет так

.Item(a(i, 1)) = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6)), "|")

Стас, можете проверить? Просто для интереса. Может действительно так лучше?