Сравнить две книги по коду и подсветить расхождения красным

Код

Option Explicit

Sub CompareTwoWorkbooksBothRed()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim fileName As String
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim arr1 As Variant, arr2 As Variant
    Dim dict1 As Object, dict2 As Object
    Dim matched2 As Object
    Dim key As String
    Dim qty1 As Double, qty2 As Double
    Dim name1 As String, name2 As String
    Dim isDiff As Boolean
    Dim diffList As String, msg As String
    Dim diffCount As Long, totalChecked As Long
    Dim onlyIn1 As Long, onlyIn2 As Long, qtyDiff As Long, nameDiff As Long

    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.ActiveSheet

    fileName = PickFile()
    If Len(fileName) = 0 Then Exit Sub

    Application.ScreenUpdating = False
    Set wb2 = Workbooks.Open(fileName, ReadOnly:=False)
    Set ws2 = wb2.ActiveSheet

    lastRow1 = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    If lastRow1 < 2 Or lastRow2 < 2 Then
        MsgBox "В одной из книг нет данных для сравнения.", vbExclamation
        wb2.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Exit Sub
    End If

    arr1 = ws1.Range("B2:F" & lastRow1).Value
    arr2 = ws2.Range("B2:E" & lastRow2).Value

    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")
    dict1.CompareMode = 1
    dict2.CompareMode = 1

    For i = 1 To UBound(arr1, 1)
        key = NormalizeKey(CStr(arr1(i, 2)))
        If Len(key) > 0 Then
            If Not dict1.Exists(key) Then dict1.Add key, i
        End If
    Next i
    For j = 1 To UBound(arr2, 1)
        key = NormalizeKey(CStr(arr2(j, 1)))
        If Len(key) > 0 Then
            If Not dict2.Exists(key) Then dict2.Add key, j
        End If
    Next j

    Set matched2 = CreateObject("Scripting.Dictionary")
    matched2.CompareMode = 1

    ws1.Range("B2:F" & lastRow1).Font.Color = RGB(51, 51, 51)
    ws2.Range("B2:E" & lastRow2).Font.Color = RGB(51, 51, 51)

    For i = 1 To UBound(arr1, 1)
        key = NormalizeKey(CStr(arr1(i, 2)))
        If Len(key) = 0 Then GoTo NextI
        totalChecked = totalChecked + 1
        name1 = CStr(arr1(i, 3))
        qty1 = Val(Replace(CStr(arr1(i, 5)), ",", "."))
        If dict2.Exists(key) Then
            j = Val(dict2(key))
            matched2(key) = True
            name2 = CStr(arr2(j, 2))
            qty2 = Val(Replace(CStr(arr2(j, 3)), ",", "."))
            isDiff = False
            If Abs(qty1 - qty2) > 0.0001 Then
                isDiff = True
                qtyDiff = qtyDiff + 1
                diffCount = diffCount + 1
                diffList = diffList & "• " & arr1(i, 2) & " — " & Left(name1, 60) & _
                           " (кол-во: " & qty1 & " vs " & qty2 & ")" & vbCrLf
            End If
            If NormalizeName(name1) <> NormalizeName(name2) Then
                isDiff = True
                nameDiff = nameDiff + 1
                diffCount = diffCount + 1
                diffList = diffList & "• " & arr1(i, 2) & " — " & Left(name1, 60) & _
                           " (номенклатура отличается)" & vbCrLf
            End If
            If isDiff Then
                ws1.Range(ws1.Cells(i + 1, "B"), ws1.Cells(i + 1, "F")).Font.Color = vbRed
                ws2.Range(ws2.Cells(j + 1, "B"), ws2.Cells(j + 1, "E")).Font.Color = vbRed
            End If
        Else
            onlyIn1 = onlyIn1 + 1
            diffCount = diffCount + 1
            diffList = diffList & "• " & arr1(i, 2) & " — " & Left(name1, 60) & _
                       " (только в 1-й книге)" & vbCrLf
            ws1.Range(ws1.Cells(i + 1, "B"), ws1.Cells(i + 1, "F")).Font.Color = vbRed
        End If
NextI:
    Next i

    For j = 1 To UBound(arr2, 1)
        key = NormalizeKey(CStr(arr2(j, 1)))
        If Len(key) = 0 Then GoTo NextJ
        If Not matched2.Exists(key) Then
            onlyIn2 = onlyIn2 + 1
            diffCount = diffCount + 1
            diffList = diffList & "• " & arr2(j, 1) & " — " & Left(CStr(arr2(j, 2)), 60) & _
                       " (только во 2-й книге)" & vbCrLf
            ws2.Range(ws2.Cells(j + 1, "B"), ws2.Cells(j + 1, "E")).Font.Color = vbRed
        End If
NextJ:
    Next j

    Application.ScreenUpdating = True
    If diffCount = 0 Then
        MsgBox "Номенклатуры и количества совпадают." & vbCrLf & vbCrLf & _
               "Проверено позиций: " & totalChecked, vbInformation, "Сравнение завершено"
    Else
        msg = "Обнаружены расхождения: " & diffCount & vbCrLf & vbCrLf & _
              "Проверено позиций: " & totalChecked & vbCrLf & _
              "  - только в 1-й книге: " & onlyIn1 & vbCrLf & _
              "  - только во 2-й книге: " & onlyIn2 & vbCrLf & _
              "  - расхождений по кол-ву: " & qtyDiff & vbCrLf & _
              "  - расхождений по номенклатуре: " & nameDiff & vbCrLf & vbCrLf & _
              "Строки с расхождениями выделены красным шрифтом в обеих книгах." & _
              vbCrLf & vbCrLf & "Детали:" & vbCrLf & diffList
        If Len(msg) > 1000 Then msg = Left(msg, 950) & vbCrLf & "... (список обрезан)"
        MsgBox msg, vbExclamation, "Сравнение завершено"
    End If
End Sub

Private Function PickFile() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Выберите книгу для сравнения"
        .Filters.Clear
        .Filters.Add "Excel files", "*.xls; *.xlsx; *.xlsm; *.xlsb"
        If .Show = -1 Then
            PickFile = .SelectedItems(1)
        Else
            PickFile = ""
        End If
    End With
End Function

Private Function NormalizeKey(s As String) As String
    Dim t As String
    t = Trim(s)
    t = Replace(t, " ", "")
    t = Replace(t, Chr(160), "")
    NormalizeKey = UCase(t)
End Function

Private Function NormalizeName(s As String) As String
    Dim t As String
    t = Trim(s)
    t = Replace(t, " ", "")
    t = Replace(t, Chr(160), "")
    t = Replace(t, """", "")
    t = Replace(t, "«", "")
    t = Replace(t, "»", "")
    t = Replace(t, "/", "")
    t = Replace(t, "-", "")
    NormalizeName = UCase(t)
End Function

Связанные члены API

Application.GetOpenFilename Range.Value Workbook.Worksheets Application.ScreenUpdating Range.End