Dim bkBook_1 As Excel.Workbook
    Dim bkBook_2 As Excel.Workbook
    
    'Даём имена книгам. Через эти имена можно обращаться к книгам.
    Set bkBook_1 = ActiveWorkbook
    Set bkBook_2 = Workbooks(2)

Sub uuu()
    Dim fp$, k$
    Dim a()
    Dim i&, p&, d&
    Dim sd As Object
'--------------------
    p = 4 'столбец с телефоном
    d = 6 'столбец с датой
    With Application.FileDialog(msoFileDialogFilePicker)'выбираем базу
        .Filters.Clear
        .Filters.Add "Microsoft Excel files", "*.xls*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show = 0 Then Exit Sub
        fp = .SelectedItems(1)
    End With
    With ThisWorkbook.ActiveSheet
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        a = .UsedRange.Value 'берём в массив диапазон (телефоны)
        Set sd = CreateObject("Scripting.Dictionary") 'создаём словарь
        For i = 1 To UBound(a) 'проходим по массиву
            If a(i, 1) <> "" Then sd.Item(a(i, 1)) = i  'собираем в словарь пары телефон/номер строки
        Next
        ReDim Preserve a(1 To UBound(a), 1 To UBound(a, 2) + 1) 'расширяем массив на 1 столбец
        Workbooks.Open fp 'открываем базу
        With ActiveWorkbook
            With .ActiveSheet
                For i = .UsedRange.Rows.Count To 1 Step -1 'проходим от последней строки базы к 1й
                    k = .Cells(i, p).Value 'ключ для поиска в словаре - телефон из базы
                    If sd.Exists(k) Then 'если ключ существует то
                        a(sd.Item(k), UBound(a, 2)) = .Cells(i, d).Value 'вносим в телефоны дату из базы
                        .Rows(i).Delete 'удаляем строку в базе
                    End If
                Next
            End With
            .Close True 'закрываем базу с сохранением изменений
        End With
        .Columns(1).NumberFormat = "@" 'делаем текстовым формат в телефонах (чтобы ведущие нули не убежали)
        .Cells(1, 1).Resize(UBound(a), UBound(a, 2)) = a 'выгружаем массив обратно на лист
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
    MsgBox "Готово!"
End Sub

If .Show = 0 Then Exit Sub