Option Explicit

Sub tt()
    Dim a(), b(), i&, wb As Object, t$
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
    With ThisWorkbook.Sheets(1).[a1].CurrentRegion.Columns(1)
        a = .Value: b = .Offset(, 2).Value
    End With
    For i = 2 To UBound(a): dic.Item(a(i, 1)) = i: Next

    Application.ScreenUpdating = False

    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Tetrad2.xlsx")
    With wb.Sheets(1).[a1].CurrentRegion.Columns(1)
        For i = 2 To .Rows.Count
            t = .Cells(i)
            If dic.exists(t) Then b(dic.Item(t), 1) = .Cells(i).Offset(, 2): .Cells(i).Offset(, 2) = Empty
        Next
    End With

    ThisWorkbook.Sheets(1).[a1].CurrentRegion.Columns(1).Offset(, 2).Value = b
    ThisWorkbook.save

    wb.Close True

    Application.ScreenUpdating = True

End Sub