Change 2 lines
Sub MatchD()
    With Range("d2", Range("d" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Resize(, 4).Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "TBC" Then
                    .Item(a(i, 4)) = a(i, 1)
                Else
                    a(i, 2) = .Item(a(i, 4))
                End If
            Next
        End With
        .Value = a
    End With
End Sub