Повторяющиеся значения - VBA (48724)

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

Здравствуйте. Нужна Ваша помощь. Имеется файл, на двух разных листах содержатся записи и надо найти повторяющиеся элементы, выставить пометки да/нет. Да, если запись повторяется, нет, если запись не повторяется. В файле повторяющиеся элементы 3 и 5 записи, а пометки выставляются для всех как нет.

                    Листинг программы
                
 
                        
                          
                    
'Собираем "слово" из 4 ячеек
asd1 = Sheets("Лист1").Cells(i, 1) & Sheets("Лист1").Cells(i, 2) & Sheets("Лист1").Cells(i, 3) & Sheets("Лист1").Cells(i, 4)
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 'Сравниваем полученные слова
    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
End If
Next j
Next i
' Цикл простановки нет
For i = 2 To List1RowsCount
    If Sheets("Лист1").Cells(i, 5) = "" Then Sheets("Лист1").Cells(i, 5) = "нет"
Next i
For j = 2 To List2RowsCount
    If Sheets("Лист2").Cells(j, 5) = "" Then Sheets("Лист2").Cells(j, 5) = "нет"
Next j

Пример_1.xlsx

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

textual
                            Листинг программы 
                        
 
                        
                          
                    
Sub CompareRows()
Dim S1 As String, S2 As String, Iz1 As Integer, Iz2 As Integer
Dim LastRow As Long, I As Long, J As Integer, TF As Boolean
Sheets(1).Activate
LastRow = ActiveSheet.UsedRange.Row + _
          ActiveSheet.UsedRange.Rows.Count - 1
For I = 1 To LastRow
  If Cells(I, 1) <> "" Then 'пропускаем пустые строки
    TF = True
    For J = 1 To 4
      S1 = Trim(Cells(I, J)): S2 = Trim(Sheets(2).Cells(I, J))
      Iz1 = InStr(S1, "*"): Iz2 = InStr(S2, "*")
      If Iz1 + Iz2 = 0 Then 'нет звёзд
        If S1 <> S2 Then
          TF = False: Exit For
        End If
      Else
        If Iz1 = 0 Or (Iz2 > 0 And Iz2 < Iz1) Then Iz1 = Iz2
        Iz1 = Iz1 - 1
        If Iz1 > 0 Then 'есть текст + звезда
          If Left(S1, Iz1) <> Left(S2, Iz1) Then
            TF = False: Exit For
          End If
        End If
      End If
    Next
    Cells(I, 6) = IIf(TF, "Да", "Нет")
  End If
Next
End Sub