Найти совпадающие строки в двух листах книги

[Evgeny_s]

Есть лист1 ( 32тыс строк) и лист 2 (64 тыс строк)

оба содержат адреса в текстовом виде в 4-х столбцах

Улица
Дом
корпус
квартира

при совпадении адресов надо в левое свободное поле F данной строки в Лист1 записать символ ( например "ЛЬГОТА")

без вашей помощи девченкам из отдела придется это делать ручками!!!
Спасибо

[IgorGO]

Sub SetF1()
  Dim c As New Collection, r As Long, s As String
  With Sheets(2)
    For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
      s = Join(Array(.Cells(r, 1), .Cells(r, 2), .Cells(r, 3), .Cells(r, 4)))
      c.Add Item:=s, Key:=s
    Next
  End With
  With Sheets(1)
    On Error Resume Next
    For r = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
      s = Join(Array(.Cells(r, 1), .Cells(r, 2), .Cells(r, 3), .Cells(r, 4)))
      c.Add Item:=s, Key:=s
      If Err.Number > 0 Then Sheets(1).Cells(r, 6) = "ËÜÃÎÒÀ": Err.Clear
    Next
  End With
End Sub

[Evgeny_s]

А как этим модулем воспользоваться, я профан в макросах!!??
Благодарю.

[EducatedFool]

я профан в макросах!

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

Десятки тысяч строк не обязательны - хватит и по 100 строк на каждом листе.

[Evgeny_s]

загрузил файл
визуально в нем есть минимум 10 похожих адресов
т.е должна появитья в поле рядом с ними текстовая ( итли числовая метка)


подскажите действия для выполлнения кода в Exele
Спасибо
Shuko_e@mail.ru

[EducatedFool]

Вот файл файл с макросом и результатами его работы:
http://excelvba.ru/XL_Files/Sample__...__15-09-57.zip

Пришлось чуточку переделать макрос Игоря:

Sub SetF1()
    Dim c As New Collection, r As Long, s As String
    On Error Resume Next
    With Sheets(2)
        For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            s = Join(Array(.Cells(r, 2), .Cells(r, 3), .Cells(r, 4), .Cells(r, 5)))
            c.Add Item:=s, Key:=s
        Next
    End With
    Err.Clear
    With Sheets(1)
        For r = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            s = Join(Array(.Cells(r, 2), .Cells(r, 3), .Cells(r, 4), .Cells(r, 5)))
            c.Add Item:=s, Key:=s
            If Err.Number > 0 Then Sheets(1).Cells(r, 6) = "+": Err.Clear
        Next
    End With
End Sub

[Evgeny_s]

Спасибо, мужики.
Здорово выручили.
Всем удачи и долгтх плодотворных.

PS
В качестве бонуса

Имитировать аргазм проще, чем эрекцию
( из наблюдений женатого с 30 летим стажем)

[Hugo121]

Чтоб оргазм был полнее, можно так код изменить (в 4 раза быстрее наступает ) :

Sub SetF1()
    Dim oDict As Object, r As Long, s As String, a, b, c
    '    Dim tm As Single: tm = Timer

    Set oDict = CreateObject("Scripting.Dictionary")

    With Sheets(2)
        b = .Range("B2:E" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
    End With

    For r = 1 To UBound(b)
        s = Join(Array(b(r, 1), b(r, 2), b(r, 3), b(r, 4)))
        If Not oDict.Exists(s) Then oDict.Add s, s
    Next

    With Sheets(1)
        a = .Range("B2:E" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
        ReDim c(1 To UBound(a), 1 To 1)

        For r = 1 To UBound(a)
            s = Join(Array(a(r, 1), a(r, 2), a(r, 3), a(r, 4)))
            If oDict.Exists(s) Then c(r, 1) = "+"
        Next
        .[f2].Resize(r).Value = c
    End With

    '    Debug.Print Timer - tm
End Sub

Ещё можно вместо

        s = Join(Array(b(r, 1), b(r, 2), b(r, 3), b(r, 4)))

писать

        s = b(r, 1) & "|" & b(r, 2) & "|" & b(r, 3) & "|" & b(r, 4)

но ускорения на таком количестве это не дало. Но можно попробовать на Ваших тысячах (аналогично и с массивом a).

[Evgeny_s]

64т и 32т проскочили за пару минут.
Спасибо всем, кто откликнулся и кто не успел..
Все сделали оперативно и грамотно.
так бы все в этом Мире.
Е.