Cześć.

Nie lubię prostych rozwiązań, więc proponuję takie. Mirek pewnie zmieści to w jednej linijce kodu. ;)

Function pobierz()
Dim conn As Object, db As Object, rst As Object, dbPath As String, keysRs As Object, KomDocelNrTel As Range, ZAKRES As Range, SPR As Range, KomDocelOld As Range, xlWB As Workbook, xlSH2 As Worksheet, test As Range
Dim i As Integer, x As Integer

On Error GoTo PrzyBłędzie

Set xlWB = ThisWorkbook
Set xlSH2 = xlWB.Sheets("Arkusz2")
Set conn = CreateObject("DAO.DBEngine.120")
Set ZAKRES = Sheets("Arkusz1").Range("a1", Range("a1").End(xlDown).Offset(0, 1))
dbPath = xlWB.FullName
Set db = conn.OpenDatabase(dbPath, False, True, "Excel 12.0 Xml;HDR=Yes;")
Set keysRs = db.openrecordset("SELECT [Numer Telefonu] FROM [Arkusz1$" & ZAKRES.Address(False, False) & "] GROUP BY [Numer Telefonu]")

If xlWB.Sheets("Arkusz2").Range("a2") = "" Then
    Set KomDocelNrTel = xlWB.Sheets("Arkusz2").Range("a2")
    Set SPR = xlSH2.Range("a1")
Else
    Set KomDocelNrTel = xlWB.Sheets("Arkusz2").Range("a1").End(xlDown).Offset(1, 0)
    Set SPR = xlSH2.Range("a1", xlSH2.Range("a1").End(xlDown))
End If

Set KomDocelOld = KomDocelNrTel

i = 0
Do Until keysRs.EOF
    x = 1
    Set rst = db.openrecordset("SELECT * FROM [Arkusz1$" & ZAKRES.Address(False, False) & "]  WHERE [Numer telefonu]=" & keysRs.Fields(0))
    Set test = SPR.Find(keysRs.Fields(0), , xlValues, xlWhole)
    
    If Not test Is Nothing Then
        Set KomDocelNrTel = test
    Else
        Set KomDocelNrTel = KomDocelOld.Offset(i, 0)
    End If
    
    KomDocelNrTel.Value = keysRs.Fields(0)
    
    Do Until rst.EOF
        KomDocelNrTel.Offset(0, x).Value = rst.Fields(1)
        rst.MoveNext
        x = x + 1
    Loop
    
    i = i + 1
    keysRs.MoveNext
Loop

KoniecPracy:
On Error Resume Next
keysRs.Close
db.Close

Set db = Nothing
Set conn = Nothing
Set keysRs = Nothing
Set xlWB = Nothing
Set xlSH2 = Nothing
Set ZAKRES = Nothing
Set test = Nothing
Set KomDocelNrTel = Nothing
Set KomDocelOld = Nothing
Set SPR = Nothing
Exit Function

PrzyBłędzie:
MsgBox Error$
Resume KoniecPracy

End Function

Kod aktualizuje tabelę w Arkuszu 2, więc jeśli numer już tam ujęty zostanie dodany z nowym statusem, to nie zostanie utworzony nowy wiersz, tylko zaktualizowany będzie już istniejący. Czyli w tabeli 2 zawsze będą unikatowe numery telefonów.