Sub GetData()
Dim wsh As Worksheet, FIO As String, month_criteria As String
Dim arr, data As Range, lr As Long, lc As Long
With Worksheets("расчет")
    month_criteria = .Range("B4").Value
    FIO = .Range("C1").Value
    With Worksheets(month_criteria)
        Set data = Worksheets(month_criteria).Cells.Find(FIO)
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(data.Row, 2), .Cells(data.Row, lc))
    End With
    .Range("B5").Resize(UBound(arr, 2), 1) = Application.Transpose(arr)
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim idData As Range, criteria_month As String
    Set idData = Intersect(Target, Range("C1"))
    If Not idData Is Nothing Then
        criteria_month = Worksheets("расчет").Range("B4").Value
        Set shData = Worksheets(criteria_month)
            If idData <> "" Then
                With shData
                    r = .Columns(1).Find(idData, , xlValues, xlWhole).Row
                    c = .Rows(1).Find("Проект", , xlValues, xlWhole).Column
                    Range("B5").Resize(3) = WorksheetFunction.Transpose(.Cells(r, 2).Resize(, 3))
                End With
            End If
    End If
End Sub

=ВПР($C$1;ДВССЫЛ($B$4&"!A2:D100");2;0)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim idData As Range, FIO As String
    Set idData = Intersect(Target, Range("B4")): FIO = Range("C1").Value
    If Not idData Is Nothing Then
        If SheetExist(Range("B4")) Then
          Set shData = Worksheets(idData.Value)
            If idData <> "" Then
                With shData
                    r = .Columns(1).Find(FIO, , xlValues, xlWhole).Row
                    c = .Rows(1).Find("Проект", , xlValues, xlWhole).Column
                    Range("B5").Resize(3) = WorksheetFunction.Transpose(.Cells(r, 2).Resize(, 3))
                End With
            End If
        Else
          MsgBox "В книге нет листа с именем: " & Range("B4")
        End If
    End If
End Sub

Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function