Sub Perenos()
Dim VremjaBook As Workbook
Dim ws As Worksheet
Dim iName As String
Dim FoundName As Range
Dim FoundDate As Range
Dim iDate As Date
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        Set VremjaBook = Workbooks("vremja.xls")
    For i = 2 To iLastRow       ' цикл по именам
      If Not IsEmpty(Cells(i, 1)) And Cells(i, 1) <> "Name" Then
        iName = Cells(i, 1)
        iDate = Cells(i, 2)
        For Each ws In VremjaBook.Worksheets 'цикл по листам
          With ws
          Set FoundName = .Columns(1).Find(iName, , xlValues, xlWhole)
           If Not FoundName Is Nothing Then
             Set FoundDate = .Rows(1).Find(iDate, , xlFormulas, xlWhole)
              If Not FoundDate Is Nothing Then
                Cells(i, 3) = .Cells(FoundName.Row, FoundDate.Column)
                Cells(i, 4) = .Cells(FoundName.Row, FoundDate.Column + 1)
              End If
           End If
          End With
        Next ws
      End If
    Next
End Sub

Sub Perenos()
Dim GraficBook As Workbook
Dim ws As Worksheet
Dim iName As String
Dim FoundName As Range
Dim FoundDate As Range
Dim iDate As Date
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        Set GraficBook = Workbooks("grafic.xls")
    For i = 2 To iLastRow                           ' цикл по именам
      If Not IsEmpty(Cells(i, 1)) And Cells(i, 1) <> "Name" Then
            iName = Cells(i, 1)
            iDate = Cells(i, 2)
        For Each ws In GraficBook.Worksheets        'цикл по листам
          With ws
          Set FoundName = .Columns(1).Find(iName, , xlValues, xlWhole)
           If Not FoundName Is Nothing Then         'нашли имя, ищем дату
             Set FoundDate = .Rows(1).Find(iDate, , xlFormulas, xlWhole)
              If Not FoundDate Is Nothing Then      'нашли и имя и дату
                                        ' проверяем не пуста ли ячейка
                If Not IsEmpty(.Cells(FoundName.Row, FoundDate.Column)) Then
                  Cells(i, 3) = .Cells(FoundName.Row, FoundDate.Column)
                Else
                  Cells(i, 3) = "0:00"
                End If
                If Not IsEmpty(.Cells(FoundName.Row, FoundDate.Column + 1)) Then
                  Cells(i, 4) = .Cells(FoundName.Row, FoundDate.Column + 1)
                Else
                  Cells(i, 4) = "0:00"
                End If
                    'Set FoundDate = Nothing
                Exit For        'если нашли имя и дату, то выход из цикла
              End If
                    Set FoundName = Nothing 'имя найдено, а даты нет
           Else                 ' не нашли имя на очередном листе
                    Set FoundName = Nothing
                    Set FoundDate = Nothing
           End If
          End With
        Next ws
        If FoundName Is Nothing And FoundDate Is Nothing Then
            Cells(i, 3) = "0:00"
            Cells(i, 4) = "0:00"
        End If
      End If
    Next
End Sub