Помогите с сортировкой в MSExcel

[reanews]

Помогите c Excel потому как сам не дотягиваю!!! Имеем 2 списка в которых имена строк частично совпадают. в диапазоне (лист1 А1:А8500 лист2 A1:A4600) на втором листе напротив каждой строки есть значение которое необходимо присвоить такой же строке, при абсолютном совпадении, в первом листе, привожу простой пример:

лист1:
А _______________В________________ С
яблоко
груша
дыня
персик
ананас
слива

Лист2:

А ________________В

груша 44
персик 33
вишня 8

и есть один ньюанс необходимо в процессе работы создать еще 2 листа, т.е. Лист3 и лист 4 в который будут переноситься те строки которые остались уникальны в первых 2х листах, только обязательно целые строки т.к. в первой таблице после пустого столбца "В" далее продолжаются строки данных, т.е. опять пример для понятности происходящего:

лист3

А_______________В

Вишня 8



Лист 4

А_______________ В_______________С_______________D

Яблоко
Ананас
Слива

Я уже нашел код с сайта Микрософта, но долеко и не совсем то, что хотелось бы:

Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
Application.ScreenUpdating = False
iListCount = Sheets("Sheet2").Range("A1:A7715"). Rows.Count
For Each x In Sheets("Sheet1").Range("A1:A4878")
For iCtr = 1 To iListCount
If x.Value = Sheets("Sheet2").Cells(iCtr, 1).Value Then
Sheets("Sheet2").Cells(iCtr, 1).Clear
iCtr = iCtr + 1
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Готово"
End Sub

Только этот код удалял ячейки в столбце со сдвигов вверх, а напротив этих ячеек есть значения и в итоге получается путаница,

Sheets("Sheet2").Cells(iCtr, 1).Delete xlShiftUp

И поэтому пришлось заменить на:

Sheets("Sheet2").Cells(iCtr, 1).Clear

в итоге аолучается список с пустыми ячейками, напротив которого через нескколько строк я вставляю такой же, делаю фильтр по уже пустым ячейкам и остается то чего макрос не нашел на перввом листе и копирую значения на 3й лист, далее сортирую как все Не пустые и в правом листе остаються только те значения которые он нашел и опять копирую на 4й уже лист, а потом предполагаю поменять названия листов sheet1 на sheet2 и сделать наоборот и тогда у меня останется только уникальные значения из второго списка. Ну вот както так... Так что ситуация несколько не та, насколько я понимаю и эту ветку форума я изучил вроде.

Это слишком долго получается. сортировка на 1ядерном пне 2.2Гц 1,5Гб оперативы длиться 2часа примерно с небольшим. а тут надо минимум 2 раза сортировать....

[SAS888]

Посмотрите вложение. Запустите макрос "Main".
На большом файле не проверял, но работать макрос должен достаточно быстро. Проверьте.