Мое решение основано на прилагаемом снимке экрана, где я обнаружил только две общие колонки между листами.
1. Код
2. Компания MRC
Я не могу найти поле Status of Summary & Data.
Я хотел бы предложить набор макросов для сравнения обоих листов для общих данных, которые будут скопированы в другой лист.
Sub CompareRanges()
Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range
Set WorkRng1 = Application.InputBox("Range A:", "", Type:=8)
Set WorkRng2 = Application.InputBox("Range B:", Type:=8)
For Each Rng1 In WorkRng1
rng1Value = Rng1.Value
For Each Rng2 In WorkRng2
If rng1Value = Rng2.Value Then
Rng1.Interior.Color = VBA.RGB(255, 0, 0)
Exit For
End If
Next
Next
End Sub
Как это устроено:
- Ответьте на оба поля ввода с соответствующим диапазоном данных из обоих листов для сравнения.
- Макрос выделит дубликаты данных на листе 1(Data Sheet) красным цветом.
- Запустите нижеприведенный макрос для копирования дубликатов данных.
- Скопируйте оба макроса как стандартный модуль.
Отредактировано:
Чтобы избежать использования второго макроса, сделайте следующее:
- Выберите диапазон данных в
DATA Sheet
и примените Auto Filter.
- Строки фильтра в красном цвете.
- Копировать отфильтрованные строки.
Поместите указатель ячейки в нужную ячейку и примените Pastes Special, затем нажмите Value.
Sub CopyRedRows()
Dim wks As Worksheet
Dim wNew As Worksheet
Dim lRow As Long
Dim lNewRow As Long
Dim x As Long
Set wks = Sheets("Data")
lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wNew = Sheets("Summary")
lNewRow = 10
For x = 1 To lRow
If wks.Cells(x, 1).Interior.Color = vbRed Then
wks.Cells(x, 1).EntireRow.Copy wNew.Cells(lNewRow, 1)
lNewRow = lNewRow + 1
End If
Next
End Sub
Sheet Name
, RGB Color Code
и значения lNewRow
доступны для редактирования.