Sub Test()
    Dim Ws As Worksheet, Sh As Worksheet, Cel As Range, Rng As Range, LR As Long
    Set Sh = Sheets("")

    Application.ScreenUpdating = False
        For Each Cel In Sh.Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)
            On Error Resume Next
                Set Ws = Worksheets(CStr(Cel.Value))
            On Error GoTo 0
    
            If Not Ws Is Nothing Then
                LR = Ws.Cells(Rows.Count, "B").End(xlUp).Row
                If LR < 5 Then GoTo Skipper
                Sh.Cells(Cel.Row, "C").Value = Ws.Range("E" & LR).Value
                
                Set Rng = Ws.Columns("F:F").Find(What:=" ", LookIn:=xlValues, LookAt:=xlWhole)
                If Not Rng Is Nothing Then Sh.Cells(Cel.Row, "D").Value = Rng.Offset(, 1)
                
                Ws.Range("H" & LR & ":H" & Ws.Cells(Rows.Count, "H").End(xlUp).Row).Copy
                Sh.Cells(Cel.Row, "F").PasteSpecial Paste:=xlPasteValues, Transpose:=True
            End If
Skipper:
            Set Ws = Nothing
    Next Cel
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub