Сравните несколько столбцов на двух листах, чтобы получить значение

Question

У меня ограниченное рабочее знание макросов Excel VBA. У меня есть два листа под названием "Сводка" и "Данные"

• Сводная таблица имеет фиксированные строки и столбцы.
• Таблица данных имеет значения в нем.

Мне нужно сравнить код, номер MRC компании и статус сводной таблицы и таблицы данных, и, если поля совпадают, получить соответствующее значение из таблицы данных в поле «Сводная информация».

Answer 1

Мое решение основано на прилагаемом снимке экрана, где я обнаружил только две общие колонки между листами.

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. Ответьте на оба поля ввода с соответствующим диапазоном данных из обоих листов для сравнения.
2. Макрос выделит дубликаты данных на листе 1(Data Sheet) красным цветом.
3. Запустите нижеприведенный макрос для копирования дубликатов данных.
4. Скопируйте оба макроса как стандартный модуль.

Отредактировано:

Чтобы избежать использования второго макроса, сделайте следующее:

1. Выберите диапазон данных в DATA Sheet и примените Auto Filter.
2. Строки фильтра в красном цвете.
3. Копировать отфильтрованные строки.

4. Поместите указатель ячейки в нужную ячейку и примените 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
   

5. Sheet Name , RGB Color Code и значения lNewRow доступны для редактирования.