Sub sravncell() 
 'Прога для сравнения двух массивов ячеек на листе "Лист2" 
 'Плюшка пока не дописана, но to be continued! 
  
  
 Dim Ok(10000, 1) As String          'Массив, в котором хранятся имена(0) и адреса(1), совпадающие в обоих массивах 
 Dim BE1(10000, 1) As String         '->>-, которые есть только в первом массиве 
 Dim BE2(10000, 1) As String         '->>-, которые есть только во втором массиве 
 Dim indOk As Integer         'Отсель, индексы соответствующих массивов... 
 Dim indBE1 As Integer 
 Dim indBE2 As Integer        '...вот до сель 
 Dim aDr1 As Integer                 'Номера первой... 
 Dim aDr2 As Integer                 'и второй строки, соответственно 
 Dim CHsize1 As String          'Размеры(по ширине)... 
 Dim CHsize2 As String          '...сортируемых массивов 
 Dim kui As Integer      'Счётчик 
 Dim Ksize1 As String          'Размеры(количество строк)... 
 Dim Ksize2 As String          '...сортируемых массивов 
  
  
 CHsize1 = "a1:b1" 
 CHsize2 = "d1:e1" 
  
 '''''''''''''''''''''''''''''''''''Дыва''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
                                         Columns(Left(CHsize2, 1) & ":" & Mid(CHsize2, 4, 1)).Select 
                                         ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear 
                                         ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add Key:=Columns(Left(CHsize2, 1)), _ 
                                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
                                         With ActiveWorkbook.Worksheets("Лист2").Sort 
                                             .SetRange Range(Left(CHsize2, 1) & ":" & Mid(CHsize2, 4, 1)) 
                                             .Header = xlGuess 
                                             .MatchCase = False 
                                             .Orientation = xlTopToBottom 
                                             .SortMethod = xlPinYin 
                                             .Apply 
                                         End With 
                                          
                                     Range(Left(CHsize2, 2)).Select 
                                     Ksize2 = 0 
                                     Do While ActiveCell.Offset(Ksize2 + 1, 0) <> "" 
                                     Ksize2 = Ksize2 + 1 
                                     Loop 
 ''''''''''''''''''''''''''''''''''''''''''''''''Енд два'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 ''''''''''''''''''''''''''''''''''''''''''''''Адын'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
     Columns(Left(CHsize1, 1) & ":" & Mid(CHsize1, 4, 1)).Select                                    'Сортировка с счёт количества записей по первому массиву 
     ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear 
     ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add Key:=Columns(Left(CHsize1, 1)), _ 
         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
     With ActiveWorkbook.Worksheets("Лист2").Sort 
         .SetRange Range(Left(CHsize1, 1) & ":" & Mid(CHsize1, 4, 1)) 
         .Header = xlGuess 
         .MatchCase = False 
         .Orientation = xlTopToBottom 
         .SortMethod = xlPinYin 
         .Apply 
     End With 
      
 Range(Left(CHsize1, 2)).Select 
 Ksize1 = 0 
 Do While ActiveCell.Offset(Ksize1 + 1, 0) <> "" 
 Ksize1 = Ksize1 + 1 
 Loop                                                                                               'Вот до этого места 
 ''''''''''''''''''''''''''''''''''''Енд адын'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
  
 '_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|Сравнение_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+| 
                         indOk = -1 
                         indBE1 = -1 
                         indBE2 = -1 
                         aDr1 = -1 
                         aDr2 = 0 
                         Do While aDr1 < Ksize1 
                             aDr1 = aDr1 + 1 
                             If ActiveCell.Offset(aDr1, 0) = ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) Then 
                                     indOk = indOk + 1 
                                     Ok(indOk, 0) = ActiveCell.Offset(aDr1, 0) 
                                     Ok(indOk, 1) = aDr1 
                                     If aDr2 < Ksize2 Then aDr2 = aDr2 + 1 
                             ElseIf ActiveCell.Offset(aDr1, 0) < ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) Then 
                                     indBE1 = indBE1 + 1 
                                     BE1(indBE1, 0) = ActiveCell.Offset(aDr1, 0) 
                                     BE1(indBE1, 1) = aDr1 
                             ElseIf ActiveCell.Offset(aDr1, 0) > ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) And aDr2 < Ksize2 Then 
                                     indBE2 = indBE2 + 1 
                                     BE2(indBE2, 0) = ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) 
                                     BE2(indBE2, 1) = aDr2 
                                     If ActiveCell.Offset(aDr1, 0) >= ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) Then aDr1 = aDr1 - 1 
                                     If aDr2 < Ksize2 Then aDr2 = aDr2 + 1 
                             Else 
                                     indBE1 = indBE1 + 1 
                                     BE1(indBE1, 0) = ActiveCell.Offset(aDr1, 0) 
                                     BE1(indBE1, 1) = aDr1 
                             End If 
                         Loop 
                          
                         Do While aDr2 <= Ksize2 
                                  indBE2 = indBE2 + 1 
                                  BE2(indBE2, 0) = ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) 
                                  BE2(indBE2, 1) = aDr2 
                                  aDr2 = aDr2 + 1 
                         Loop 
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Конец сравнения''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
  
 Application.ScreenUpdating = False 
  
 For kui = 0 To indOk 
 ActiveCell.Offset(Ok(kui, 1), 0).Range(CHsize1).Copy 
 ActiveCell.Offset(kui, 10).Range(CHsize1).Select 
 ActiveSheet.Paste 
 Range(Left(CHsize1, 2)).Select 
 Next kui 
  
 For kui = 0 To indBE1 
 ActiveCell.Offset(BE1(kui, 1), 0).Range(CHsize1).Copy 
 ActiveCell.Offset(kui, 20).Range(CHsize1).Select 
 ActiveSheet.Paste 
 Range(Left(CHsize1, 2)).Select 
 Next kui 
  
 For kui = 0 To indBE2 
 ActiveCell.Offset(BE2(kui, 1), 0).Range(CHsize2).Copy 
 ActiveCell.Offset(kui, 20).Range(CHsize2).Select 
 ActiveSheet.Paste 
 Range(Left(CHsize1, 2)).Select 
 Next kui 
  
 Application.ScreenUpdating = True 
 End Sub