Поиск повторяющихся записей - VBA

Узнай цену своей работы

Формулировка задачи:

Добрый день. Нужна Ваша помощь. Имеется файл, на двух разных листах содержатся записи и надо найти повторяющиеся элементы, выставить пометки да/нет. Да, если запись повторяется, нет, если запись не повторяется. Проблема возникла в самом выводе пометок. Не судите строго, изучаю второй день VBA. Cells(i, 6).Select ActiveCell.FormulaR1C1 = " = IF ((A1=A2) AND (B1=B2) AND (C1=C2) AND (D1=D2),""да"")" Selection.Copy Range("F1:F100").Select ActiveSheet.Paste

Решение задачи: «Поиск повторяющихся записей»

textual
Листинг программы
Option Explicit
Sub macro1()
Dim i#, j#, List1RowsCount#, List2RowsCount#, asd1$, asd2$ 'объявляем переменные
 
List1RowsCount = Sheets("Лист1").Cells(1, 1).End(xlDown).Row ' определяем последнюю строку на Лист1
List2RowsCount = Sheets("Лист2").Cells(1, 1).End(xlDown).Row ' определяем последнюю строку на Лист2
 
For i = 2 To List1RowsCount 'запускаем цикл по листу 1
For j = 2 To List2RowsCount ' запускаем цикл по листу 2
 
 
'собираем "слово" из 4 ячеек листа1
asd1 = Sheets("Лист1").Cells(i, 1) & Sheets("Лист1").Cells(i, 2) & Sheets("Лист1").Cells(i, 3) & Sheets("Лист1").Cells(i, 4)
'собираем "слово" из 4 ячеек листа1
asd2 = Sheets("Лист2").Cells(j, 1) & Sheets("Лист2").Cells(j, 2) & Sheets("Лист2").Cells(j, 3) & Sheets("Лист2").Cells(j, 4)
 
 
 
If asd1 = asd2 Then 'сравниваем полученные слова
    ' если условие истинное то проверяем ячейку на пустоту и если пустая ставим "да"
    ' на листе 1 и на листе 2
    If Sheets("Лист1").Cells(i, 5) = "" Then Sheets("Лист1").Cells(i, 5) = "Да"
    If Sheets("Лист2").Cells(j, 5) = "" Then Sheets("Лист2").Cells(j, 5) = "Да"
Exit For ' выход из цикла j (строку надо удалить если на листе 2 предполагается дублирование информации)
End If ' закрытие условия
 
 
Next j ' закрытие цикла j
Next i ' закрытие цикла i
 
' цикл простановки нет на листе 1
For i = 2 To List1RowsCount
    If Sheets("Лист1").Cells(i, 5) = "" Then Sheets("Лист1").Cells(i, 5) = "Нет"
Next i
 
' цикл простановки нет на листе 2
For j = 2 To List2RowsCount
    If Sheets("Лист2").Cells(j, 5) = "" Then Sheets("Лист2").Cells(j, 5) = "Нет"
Next j
 
MsgBox "Готово" ' вывод сообщения о завершении работы макроса
End Sub

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

8   голосов , оценка 3.625 из 5