Sub cbMakeIskluchSpsok_Click()
 
    ' ошибки обрабатываем сами.
    On Error Resume Next
    
    'Переменные для хранения имен файлов старого и нового списков
    Dim old_sp_book As String
    Dim new_sp_book As String
    Dim iskl_sp_book As String
    'Переменная для хранения имени файла списка исключенных
    Dim old_spisok As Workbook
    Dim new_spisok As Workbook
    Dim iskl_spisok As Workbook
    'Рабочие листы в файлах (все первые)
    Dim old_sheet As Worksheet
    Dim new_sheet As Worksheet
    Dim iskl_sheet As Worksheet
    
    'Устанавливаем активным каталог книги, из которой запущен макрос
    ChDir ThisWorkbook.Path
    
    'Признак ошибки
    Dim bError As Boolean
    
    'Открываем файл старого списка
    Set old_spisok = Open_Xls("old_sp")
    'Открываем файл нового списка
    Set new_spisok = Open_Xls("new_sp")
    
    bError = (old_spisok Is Nothing) Or (new_spisok Is Nothing)
    
    If Not bError Then
        
        iskl_sp_book = ThisWorkbook.Path & "\" & "Iskl_spisok_Added " & CStr(Date) & ".xls"
        'Создаем ексель-книгу для списка исключенных
        Set iskl_spisok = Workbooks.Add
        'Сохраняем созданную эксель-книгу со списка исключенных
        iskl_spisok.SaveAs Filename:=iskl_sp_book, FileFormat:=xlExcel8, _
            Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
            CreateBackup:=False
        
        Set old_sheet = old_spisok.Sheets(1)
        Set new_sheet = new_spisok.Sheets(1)
        Set iskl_sheet = iskl_spisok.Sheets(1)
        
        'Последняя строка с данными
        Dim new_sheet_end_row As Long, CurrNumericRow As Long
        new_sheet_end_row = new_sheet.Cells.SpecialCells(xlLastCell).Row
        
        'Переменная-счетчик для перебора строк нового списка
        Dim i_new As Long, i_iskl As Long
        
        For i_new = 1 To new_sheet_end_row
            CurrNumericRow = Val(new_sheet.Cells(i_new, 1).Value)
            If CurrNumericRow > 0 Then
                ' текущая строка в исключениях
                i_iskl = i_iskl + 1
                old_sheet.Rows(CurrNumericRow).Copy iskl_sheet.Rows(i_iskl)
            Else
                'ничего не делать :)))
            End If
        Next i_new
            
    End If 'Not bError
    
    'Закрываем файлы
    Close_Xls iskl_spisok, True 'сохранить изменения
    Close_Xls old_spisok, False 'не сохранять изменения
    Close_Xls new_spisok, False 'не сохранять изменения
 
    Set old_spisok = Nothing
    Set new_spisok = Nothing
    Set iskl_spisok = Nothing
 
End Sub

' Открывает рабочую книгу с перебором расширений.
' Возвращает объект Workbook или Nothing в случае ошибки.
Function Open_Xls(ByVal sFileName As String) As Workbook
    Dim sExt, sFile As String
    Set Open_Xls = Nothing
    
    For Each sExt In Array(".xls", ".xlsx")
        sFile = ActiveWorkbook.Path + "\" + sFileName + sExt
        If Dir(sFile) <> "" Then
            Set Open_Xls = Workbooks.Open(sFile)
            Exit For
        End If
    Next sExt

    If Open_Xls Is Nothing Then
        MsgBox "Ошибка открытия: " & sFileName
    End If

End Function

' Закрывает рабочую книгу.
Sub Close_Xls(ByVal oWorkbook As Workbook, Optional ByVal bSaveChanges As Boolean)
    If Not oWorkbook Is Nothing Then
        oWorkbook.Close bSaveChanges 'True = сохранять изменения
    End If
End Sub

Sub cbMakeIskluchSpsok_Click()
 
    'Переменные для хранения имен файлов старого и нового списков
    Dim old_sp_book As String
    Dim new_sp_book As String
    'Переменная для хранения имени файла списка исключенных
    Dim old_spisok As Workbook
    Dim new_spisok As Workbook
    Dim iskl_spisok As Workbook
    
    'Устанавливаем активным каталог книги, из которой запущен макрос
    ChDir (ThisWorkbook.Path)
    'Устанавливаем режим копирования-вставки
    Application.CutCopyMode = True
    
    'Открываем файл старого списка
    If Dir(ActiveWorkbook.Path + "\" + "old_sp.xls") = "" Then
    
        Workbooks.Open ActiveWorkbook.Path + "\" + "old_sp.xlsx"
        Set old_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "old_sp.xlsx")
    
    Else
    
        Workbooks.Open ActiveWorkbook.Path + "\" + "old_sp.xls"
        Set old_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "old_sp.xls")
 
    End If
 
    'Открываем файл нового списка
    If Dir(ThisWorkbook.Path + "\" + "new_sp.xls") = "" Then
    
        Workbooks.Open ActiveWorkbook.Path + "\" + "new_sp.xlsx"
        Set new_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "new_sp.xlsx")
    
    Else
    
        Workbooks.Open ActiveWorkbook.Path + "\" + "new_sp.xls"
        Set new_spisok = Workbooks.Open(ThisWorkbook.Path + "\" + "new_sp.xls")
    
    End If
 
    'Создаем ексель-книгу для списка исключенных
    Set iskl_spisok = Workbooks.Add
    
    'Сохраняем и закрываем созданную эксель-книгу со списка исключенных
    iskl_spisok.SaveAs Filename:=ThisWorkbook.Path & "\" & "Iskl_spisok_Added " & CStr(Date) & ".xls", 

FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    
   
    'Переменные-счестчики для перебра строк нового старого списка, старого списка и списка сиключенных
    'Переменная-счетчик для перебора строк нового списка
    Dim i As Long
    'Переменная-счетчик для перебора строк старого списка
    'Dim j As Long
    'Переменная-счетчик для перебора строк списка исключенных
    Dim k As Long
    'Переменная для хранения номера непстой строки в новом списке
    Dim CurrNumericRow As Long
    'Метка для продолжения цикла с перебором строк в новом списке
    Dim Metka As Label
    
    '''Действия по формированию списка исключенных граждан
    'Активация файла нового списка
    i = 1
    k = 1
    
Metka:
    
    new_spisok.Activate
    
    ActiveWorkbook.Sheets(1).Activate
    
    Do While i <> 65535
    
    
        If ActiveSheet.Range(Cells(i, 1).Address).Text <> "" And IsNumeric(ActiveSheet.Range(Cells(i, 

1).Address).Text) = True Then
        
                        CurrNumericRow = CLng(ActiveSheet.Range(Cells(i, 1).Address).Text)
                        
                        old_spisok.Activate
                        
                        ActiveWorkbook.Sheets(1).Activate
            
                        ActiveSheet.Range(Cells(CurrNumericRow, 1).Address & ":" & Cells(CurrNumericRow, 

11).Address).Select
                                
                        Selection.Copy
                        
                       'Вставка ранее скопированного дисапозона ячеек в список исключенных граждан
                        iskl_spisok.Activate
                            
                        ActiveWorkbook.Sheets(1).Activate
                        
                       
                        Do While k <> 65535
                        
                            If ActiveSheet.Range(Cells(k, 1).Address).Text = "" Then
                                
                                ActiveSheet.Range(Cells(k, 1).Address).Select
                                
                                ActiveSheet.Paste
                                
                                Exit Do
                            
                            Else
                                    
                                k = k + 1
                            
                            End If
        
        
                        Loop

            Else
                        
                    'ничего не делать :)))
                    
            End If
            
           i = i + 1
            
     Loop
        
    'Сохранение сформированного файла-списка исключенных
    'iskl_sp_book.SaveAs "????_?_?????\??????_???????????.xls"
 
End Sub