Сравнение двух таблиц выделение совпадающих ячеек

[Панчез]

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

сравните так:

Sub CompareRanges()
  Const cGreen& = 5287936, cYellow& = 65535
  Dim rg(1 To 2) As Range, r&, c&, i&, ic&
  On Error Resume Next
  Set rg(1) = Application.InputBox("Отметьте ПЕРВЫЙ диапазон", Type:=8): If Err Then End
  Set rg(2) = Application.InputBox("Отметьте ВТОРОЙ диапазон", Type:=8): If Err Then End
  On Error GoTo 0
  If rg(1).Rows.Count <> rg(2).Rows.Count Or rg(1).Columns.Count <> rg(2).Columns.Count Then
    MsgBox "Вы отметили кривые диапазоны!", vbCritical, "Аварийнре завершение": Exit Sub
  End If
  Application.ScreenUpdating = False
  For r = 1 To rg(1).Rows.Count
    For c = 1 To rg(1).Columns.Count
      ic = IIf(rg(1).Cells(r, c) = rg(2).Cells(r, c), cGreen, cYellow)
      For i = 1 To 2: rg(i).Cells(r, c).Interior.Color = ic: Next
    Next
  Next
  Application.ScreenUpdating = True
End Sub

Потрясающе IgorGO код отлично работает! Вы превзошли все мои ожидания!) Спасибо. Это именно то что и требовалось реализовать. Конечно же я сделаю вклад в поддержку и развитие через яндекс.м.. Можно еще немного улучшить механизм сравнения? Сейчас сравнивает все разряды ячейки, например: в ячейке отображено значение 1,2 (это округлено), если нажать на эту ячейку то в ней: 1,178565 или формула которая при вычислении дает тоже много не округленных разрядов. Можно ли сравнивать именно то значение, которое отображено в ячейке (округленное) так сказать, на поверхности, а не внутри? И можно еще не сравнивать пустые ячейки?
А так код супер лаконичный и удобный функционал.

[IgorGO]

Sub CompareRanges()
  Const cGreen& = 5287936, cYellow& = 65535
  Dim rg(1 To 2) As Range, r&, c&, i&, ic&
  On Error Resume Next
  Set rg(1) = Application.InputBox("Отметьте ПЕРВЫЙ диапазон", Type:=8): If Err Then End
  Set rg(2) = Application.InputBox("Отметьте ВТОРОЙ диапазон", Type:=8): If Err Then End
  On Error GoTo 0
  If rg(1).Rows.Count <> rg(2).Rows.Count Or rg(1).Columns.Count <> rg(2).Columns.Count Then
    MsgBox "Вы отметили кривые диапазоны!", vbCritical, "Аварийнре завершение": Exit Sub
  End If
  Application.ScreenUpdating = False
  For r = 1 To rg(1).Rows.Count
    For c = 1 To rg(1).Columns.Count
      If rg(1).Cells(r, c) <> rg(1).Cells(r, c).Text Then
        ic = IIf(rg(1).Cells(r, c).Text = rg(2).Cells(r, c).Text, cGreen, cYellow)
      Else
        ic = IIf(rg(1).Cells(r, c) = rg(2).Cells(r, c), cGreen, cYellow)
      End If
      If Not IsEmpty(rg(1).Cells(r, c)) Or (Not IsEmpty(rg(2).Cells(r, c))) Then
        For i = 1 To 2: rg(i).Cells(r, c).Interior.Color = ic: Next
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub

[Панчез]

Большое спасибо!