Макрос для добавления нужных строк из одной таблицы в другую

Sub Внести_сотрудника()
    Dim ws As Worksheet, lastRow&, r As Range, v, col As New Collection
    
    Set ws = Sheets("Spisok")
    ws.Activate
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    
    With Sheets("Выгрузка")
        Set r = .[a1]
        On Error Resume Next
        Do
            Set r = .Cells.Find("Внести", r)
            Err.Clear
            col.Add .Range(.Cells(r.Row, 1), .Cells(r.Row, r.Column - 1)), r.Address
            If Err Then Exit Do
        Loop
    End With
    
    For Each v In col
        v.Copy
        ws.Cells(lastRow, 1).Activate
        ws.Paste
        lastRow = lastRow + 1
    Next
    
End Sub

With Sheets("Выгрузка")
        Set r = .[a1]
        On Error Resume Next
        Do
            Set r = .Cells.Find("Внести", r)
            Err.Clear
            col.Add .Range(.Cells(r.Row, 1), .Cells(r.Row, r.Column - 1)), r.Address
            If Err Then Exit Do
        Loop
    End With

    With Sheets("Выгрузка")
        Set r = .[a1]
        On Error Resume Next
        Do
            Set r = .Cells.Find("Внести", r)
            r.Value = "Ок"
            Err.Clear
            col.Add .Range(.Cells(r.Row, 1), .Cells(r.Row, r.Column - 1)), r.Address
            If Err Then Exit Do
        Loop
    End With

Sub Внести_сотрудника()
    Dim lastRow&, r As Range, v, col As New Collection
    Sheets("Spisok").Activate
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    With Sheets("Выгрузка")
        Set r = .[a1]
        On Error Resume Next
        Do
            Set r = .Cells.Find("Внести", r)
            
            r.Value = "Ок"
            Err.Clear
            
            col.Add .Range(.Cells(r.Row, 1), .Cells(r.Row, r.Column - 1)), r.Address
            
             'Здесь можно убрать цвет из импортной строки вкладки Выгрузка я ее пока закоментировал
'            .Range(.Cells(r.Row, 1), .Cells(r.Row, r.Column)).Interior.ColorIndex = xlNone  'убираем цвет
            
            If Err Then Exit Do
            
        Loop
        If col.Count = 0 Then MsgBox "Ничего не найденно", vbExclamation: Exit Sub
    End With
    
    For Each v In col
        v.Copy
        With Range(Cells(lastRow, 1), Cells(lastRow, v.Count))
            .Select
            ActiveSheet.Paste
            .Interior.ColorIndex = xlNone 'убираем цвет из вставленной строки
 
        End With
        lastRow = lastRow + 1
    Next
    Application.CutCopyMode = False
 
End Sub

Sub Определяем_вновь_принятых()
Dim oWBthis As Object
Dim oWSthis As Object
Dim oWSbase As Object
Dim i, j As Integer
 
Call Prepare
 
Set oWBthis = ThisWorkbook
Set oWSthis = oWBthis.Worksheets("Spisok")
Set oWSbase = oWBthis.Worksheets("Выгрузка")
 
i = 2
Do While Len(oWSthis.Cells(i, 1).Value) > 0
j = 2
Do While Len(oWSbase.Cells(j, 1).Value) > 0
If oWSbase.Cells(j, 1).Value = oWSthis.Cells(i, 1).Value Then
oWSbase.Cells(j, 12).Value = "Ок"
Else: oWSbase.Cells(j, 12).Value = "Внести"
End If
j = j + 1
Loop
i = i + 1
Loop
                   
Сall Ended
 
End Sub
 
Sub Prepare()
    Application.AskToUpdateLinks = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    ActiveSheet.DisplayPageBreaks = False
End Sub
Sub Ended()
    Application.AskToUpdateLinks = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub