Sub Макрос1()
    Dim sd As Object, arr, arr_rez, y, k As Long, n As Long, m As Long
    Set sd = CreateObject("Scripting.Dictionary")
    k = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("A1:Q" & k)
    k = 0
    For n = 1 To UBound(arr)
        If IsNumeric(arr(n, 1)) And Not IsEmpty(arr(n, 1)) Then
            If Not sd.Exists(arr(n, 2)) Then
                Set sd(arr(n, 2)) = CreateObject("Scripting.Dictionary")
                sd(arr(n, 2)).Add "working", 0
                sd(arr(n, 2)).Add "weekend", 0
                sd(arr(n, 2)).Add "haurs", 0
                k = k + 1
            End If
            For m = 3 To 17
                If IsNumeric(arr(n, m)) Then
                    sd(arr(n, 2))("working") = sd(arr(n, 2))("working") + 1
                    sd(arr(n, 2))("haurs") = sd(arr(n, 2))("haurs") + arr(n, m)
                ElseIf arr(n, m) = "В" Then
                    sd(arr(n, 2))("weekend") = sd(arr(n, 2))("weekend") + 1
                End If
            Next
        End If
    Next
    ReDim arr_rez(0 To k + 1, 1 To 4)
    arr_rez(0, 1) = "ФИО"
    arr_rez(0, 2) = "Выходные дни"
    arr_rez(0, 3) = "Рабочие дни"
    arr_rez(0, 4) = "Часы"
    n = 1
    For Each y In sd
        arr_rez(n, 1) = y
        arr_rez(n, 2) = sd(y)("weekend")
        arr_rez(n, 3) = sd(y)("working")
        arr_rez(n, 4) = sd(y)("haurs")
        n = n + 1
    Next
    Range("T1").Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
End Sub

=СУММ(ЕСЛИОШИБКА((B30=$B$1:$B$26)*$C$1:$Q$26;))