Сравнение данных в листах.

[VictorM]

byaka86, тут чёт подумалось, а если несколько изменить условие задачи и не вырезать повторяющиеся строки, а наоборот, поместить неповторяющиеся строки на другой лист? Ведь я так понимаю, Вам нужно получить различие в листах. Может так будет быстрее? По крайней мере на 50-ти строках, что Вы дали, сработало "на раз".

Код: Выделить всё

Sub test()
 With Application
         .ScreenUpdating = False
         .Calculation = xlManual
Application.GoTo Reference:=Worksheets("Результат").Range("A2")
Worksheets("Результат").Rows("1:50").Delete Shift:=xlUp
Application.GoTo Reference:=Worksheets("Лист3").Range("A2")
Worksheets("Лист3").Rows("1:50").Delete Shift:=xlUp
Worksheets("Лист2").Rows("1:1").Copy Destination:=Worksheets("Результат").Range("A1")
col = 50 'Ваше кол-во строк
Application.GoTo Reference:=Worksheets("Лист2").Range("A2")
obraz2 = ActiveCell.Value
Do
ver:
Application.GoTo Reference:=Worksheets("журнал проводок").Range("B2")
obraz = ActiveCell.Value
s = 0
 For i = 1 To col
        If obraz = obraz2 Then
        s = s + 1
        End If
        ActiveCell.Offset(1, 0).Activate
        obraz = ActiveCell.Value
Next i
        If s > 0 Then
        Worksheets("Лист2").Activate
        ActiveCell.Offset(1, 0).Activate
        obraz2 = ActiveCell.Value
        If obraz2 = "" Then Worksheets("Результат").Activate: Exit Sub
        GoTo ver
        Else
        Worksheets("Лист2").Activate
        ActiveCell.Copy
        Worksheets("Результат").Activate
        ActiveSheet.Paste
        ActiveCell.Offset(1, 0).Activate
        Worksheets("Лист2").Activate
        ActiveCell.Offset(1, 0).Activate
        obraz2 = ActiveCell.Value
        If obraz2 = "" Then Worksheets("Результат").Activate: Exit Sub
        End If
Loop
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

Опять же, это только пример. И в нем присутствуют Activate с которыми я пытаюсь бороться .

[VictorM]

То же самое, но "покрасивше"

Код: Выделить всё

Sub НеСовпадения()
Dim r1, r2 As Range
Set r1 = Worksheets("журнал проводок").Range("B2:B50")
Set r2 = Worksheets("Лист2").Range("A2:A50")
Application.Goto Reference:=Worksheets("Результат").Range("A2")
s = 0
k = 0
For Each cell2 In r2
    For Each cell1 In r1
        If cell2.Value = cell1.Value Then
        s = s + 1
        End If
    Next
        If s = 0 Then
            ActiveCell.Offset(k, 0).Value = cell2.Value
            k = k + 1
        End If
        If s > 0 Then
            s = 0
        End If
Next
End Sub

работает достаточно шустро.

[byaka86]

Спасибо большое, завтра попробую так, но сегодня я придумал ещё одну вешь т.к. после запуска появилась новая проблема: на первом листе есть записи отсутствующие на втором. Поэтому я засунул туда ещё один цикл и теперь роботает (правда долго - но лучше так чем никак )
Спасибо за отзывчивость!!!

[VictorM]

В любом случае советую брать за основу второй код НеСовпадения. Скорость его работы на порядок (а может и более) больше первоначальных вариантов. Удачи!