Option Explicit

Sub poisk()
Dim fnd As Range, cl%, rw&, r&: r = 16
Const adrRngTBL1$ = "B2:E12"

    Do Until Cells(r, "B").Value = ""
        Set fnd = Range(adrRngTBL1).Find(Cells(r, "B").Value, Range("B2"), xlValues, xlWhole, xlByRows)
        If Not fnd Is Nothing Then
            rw = fnd.Row: cl = fnd.Column: Set fnd = Nothing
            With Cells(r, "B")
                .Offset(0, 1).Value = Cells(rw, "G").Value
                .Offset(0, 2).Value = Cells(1, cl).Value
                .Offset(0, 3).Value = Cells(rw, cl + 7).Value
            End With
        End If
        r = r + 1
    Loop
End Sub