Хочу узнать у знатоков, данный код логичный, правильный?
| Код |
|---|
Sub CompareArrays()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Сравнение")
Dim arr1 As Variant, arr2 As Variant
Dim keyCol1 As Integer, keyCol2 As Integer
Dim dict1 As Object, dict2 As Object
Dim key As Variant
Dim r As Long, c As Long
Dim rowIndex As Variant
' Определяем массивы данных
arr1 = ws.Range("A2:I300").Value ' Замените на диапазон вашей первой таблицы
arr2 = ws.Range("J2:R300").Value ' Замените на диапазон вашей второй таблицы
' Определяем столбцы ключей (1 - это первый столбец в массиве)
keyCol1 = 1
keyCol2 = 1
' Создаем словари для хранения ключей и индексов
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
' Заполняем словари данными из массивов
For r = 1 To UBound(arr1, 1)
key = arr1(r, keyCol1) & arr1(r, keyCol1 + 1)
dict1(key) = r
Next r
For r = 1 To UBound(arr2, 1)
key = arr2(r, keyCol2) & arr2(r, keyCol2 + 1)
dict2(key) = r
Next r
' Сравниваем массивы и выделяем изменения
For Each key In dict1.Keys
If Not dict2.exists(key) Then
' Удаленные данные - синим цветом
rowIndex = dict1(key)
For c = 1 To UBound(arr1, 2)
ws.Cells(rowIndex + 1, c).Interior.Color = RGB(0, 0, 255)
Next c
Else
rowIndex = dict1(key)
For c = 1 To UBound(arr1, 2)
If arr1(rowIndex, c) <> arr2(dict2(key), c) Then
' Измененные данные - красным цветом
ws.Cells(rowIndex + 1, c).Interior.Color = RGB(255, 0, 0)
ws.Cells(dict2(key) + 1, c + 9).Interior.Color = RGB(255, 0, 0)
End If
Next c
' Строка с изменениями - желтым цветом только первый столбец
ws.Cells(rowIndex + 1, 1).Interior.ColorIndex = 6
dict2.Remove key
End If
Next key
' Новые данные - зеленым цветом
For Each key In dict2.Keys
rowIndex = dict2(key)
For c = 1 To UBound(arr2, 2)
ws.Cells(rowIndex + 1, c + 9).Interior.Color = RGB(0, 255, 0)
Next c
Next key
MsgBox "Сравнение завершено.", vbInformation
End Sub
|
