Sub Макрос1()
    Dim arr, rez, m As Long, n As Long, k As Long
    Set sotrud = CreateObject("Scripting.Dictionary")
    Set eda = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    m = 0
    k = 0
    For n = 1 To lr
        If Cells(n, 1).IndentLevel = 0 Then
            If Not sotrud.Exists(Cells(n, 1).Value) Then
                m = m + 1
                sotrud.Add Cells(n, 1).Value, m
            End If
        Else
            If Not eda.Exists(Cells(n, 1).Value) Then
                k = k + 1
                eda.Add Cells(n, 1).Value, k
            End If
        End If
    Next
    arr = Range("A1:B" & lr).Value
    ReDim rez(0 To k, 0 To m)
    For n = 1 To UBound(arr)
        If sotrud.Exists(arr(n, 1)) Then clm = sotrud(arr(n, 1)): rez(0, clm) = arr(n, 1)
        If eda.Exists(arr(n, 1)) Then
            If rez(eda(arr(n, 1)), 0) = "" Then rez(eda(arr(n, 1)), 0) = arr(n, 1)
            rez(eda(arr(n, 1)), clm) = rez(eda(arr(n, 1)), clm) + arr(n, 2)
        End If
    Next
    [f1].Resize(UBound(rez) + 1, UBound(rez, 2) + 1) = rez
End Sub

=ТРАНСП(ФИЛЬТР(C12;ЛЕВСИМВ(C12;3)="КН1"))

=УНИК(ФИЛЬТР(C12;НЕ(ЛЕВСИМВ(C12;3)="КН1")*(C12<>"")))