Учитывая два листа с данными, я хочу показать различия на третьем листе

Question

Я могу сравнить два листа и выделить различия красным и желтым цветами на втором листе.Я хотел бы иметь возможность скопировать второй лист на третий лист и сделать выделение там, чтобы мои первый и второй исходные листы остались нетронутыми.

Я попытался создать третий лист и попытаться скопировать, используя .copy, но это не сработало.

Answer 1

Отличия выделения

Основные моменты

• Создание копии второго рабочего листа.
• Переименование нового рабочего листа.
• Расчетиспользуемый диапазон (Not UsedRange).
• Создание объединений диапазонов для желтого и красного.
• Применение форматов к объединениям диапазонов.

Код

Sub HighDiff()

  Const cVntWs1 As Variant = "Sheet1"       ' First Worksheet Name/Index
  Const cVntWs2 As Variant = "Sheet2"       ' Second Worksheet Name/Index
  Const cStrWsDiff As String = "Diff"       ' Diff Worksheet Name

  Dim URng As Range                         ' Used Range (Second Worksheet)
  Dim uCell As Range                        ' Range Control Variable
  Dim URng1 As Range                        ' First Union of Ranges
  Dim URng2 As Range                        ' Second Union of Ranges

  ' Create a copy of Second Worksheet (Diff Worksheet)
  ThisWorkbook.Worksheets(cVntWs2).Copy after:=ThisWorkbook.Worksheets(cVntWs2)

  With ThisWorkbook.Worksheets(ThisWorkbook.Worksheets(cVntWs2).Index + 1)

    ' Rename Diff Worksheet.
    .Name = cStrWsDiff

    ' Calculate the used range (Not UsedRange) in Diff Worksheet.
    If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
        Is Nothing Then Set URng = .Range(.Cells(.Cells.Find("*", _
        .Cells(.Rows.Count, .Columns.Count)).Row, .Cells.Find("*", _
        .Cells(.Rows.Count, .Columns.Count), , , 2).Column), .Cells(.Cells _
        .Find("*", , , , 1, 2).Row, .Cells.Find("*", , , , 2, 2).Column))

    ' Create unions of ranges.
    For Each uCell In URng
      If uCell.Value <> ThisWorkbook.Worksheets(cVntWs1) _
          .Cells(uCell.Row, uCell.Column).Value Then
        If Not URng1 Is Nothing Then
          Set URng1 = Union(URng1, .Cells(1, uCell.Column))
          Set URng2 = Union(URng2, .Cells(uCell.Row, uCell.Column))
         Else
          Set URng1 = .Cells(1, uCell.Column)
          Set URng2 = .Cells(uCell.Row, uCell.Column)
        End If
      End If
    Next

    ' Apply formatting to unions of ranges.
    URng1.Interior.Color = vbYellow
    URng2.Interior.Color = vbRed

  End With

  ' Release object references.
  Set URng2 = Nothing
  Set URng1 = Nothing
  Set uCell = Nothing
  Set URng = Nothing

End Sub

Answer 2

Предполагая, что вы довольны своим действительным кодом, просто добавьте третий лист, чтобы отобразить выделение цветов:

Sub checked()
    Dim mycell As Range
    Dim shtSheet1 As Worksheet
    Dim shtSheet2 As Worksheet
    Dim shtSheet3 As Worksheet

    Set shtSheet1 = Worksheets("Sheet1")
    Set shtSheet2 = Worksheets("Sheet2")
    Set shtSheet3 = Worksheets("Sheet3")

    With Worksheets("Sheet2")
        For Each mycell In .UsedRange
            If Not mycell.Value = shtSheet1.Range(mycell.Address).Value Then
                shtSheet3.Cells(1, mycell.Column).Interior.Color = vbYellow
            End If
            If Not mycell.Value = shtSheet1.Cells(mycell.Row, mycell.Column).Value Then
                shtSheet3.Range(mycell.Address).Interior.Color = vbRed
            End If
        Next
    End With
End Sub