Option Explicit

Sub Main()
    Dim rSource As Range
    Set rSource = Range("A2:C8")

    Dim arrTasks As Variant
    arrTasks = GetArrTasks(Range("A2:C8"))
    
    If Not IsEmpty(arrTasks) Then
        Dim nSotrudnikov As Long
        nSotrudnikov = Range("C12").Value
        
        Dim orr As Variant
        orr = DistribTasks(arrTasks, nSotrudnikov)
        
        OutPutArr orr, rSource
    End If
End Sub

Sub OutPutArr(arr As Variant, rSource As Range)
    With Workbooks.Add(1)
        With .Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            rSource.Range("A1:B1").Copy .Columns("A:B")
            .Cells = arr
        End With
        .Saved = True
    End With
End Sub

Function DistribTasks(arrTasks As Variant, nSotrudnikov As Long) As Variant
    Dim nTasks As Long
    nTasks = UBound(arrTasks, 1)
    
    Dim brr As Variant
    ReDim brr(1 To nTasks)
    
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim s As String
    Dim optS As String
    
    Dim avg As Double
    Dim locAvg As Double
    Dim optAvg As Double
    For j = 1 To nTasks
        avg = avg + arrTasks(j, 2) / nSotrudnikov
    Next
    optAvg = 6 * avg
    
    For i = 0 To nTasks ^ nSotrudnikov - 1
        s = Right(String(nTasks, "0") & СистемаСчисления(CStr(i), 10, CStr(nSotrudnikov)), nTasks)
        For j = 1 To nTasks
            x = Mid(s, Len(s) - (j - 1), 1) + 1
            brr(x) = brr(x) + arrTasks(j, 2)
        Next
        
        locAvg = 0
        For j = 1 To nTasks
            locAvg = locAvg + Abs(brr(j) - avg)
        Next
        If optAvg > locAvg Then
            optAvg = locAvg
            
            optS = s
        End If
        
        For j = 1 To nTasks
            brr(j) = 0
        Next
    Next
    '---------------------------------------
    ReDim brr(1 To nTasks, 1 To 3)
    s = optS
    For j = 1 To nTasks
        x = Mid(s, Len(s) - (j - 1), 1) + 1
        brr(j, 1) = arrTasks(j, 1)
        brr(j, 2) = arrTasks(j, 2)
        brr(j, 3) = x
    Next
    
    DistribTasks = brr
End Function

Function GetArrTasks(r As Range) As Variant
    Dim arr As Variant
    arr = r
    Dim n As Long
    Dim y As Long
    For y = 1 To UBound(arr, 1)
        If arr(y, 3) = "ДА" Then n = n + 1
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To 2)
        n = 0
        For y = 1 To UBound(arr, 1)
            If arr(y, 3) = "ДА" Then
                n = n + 1
                brr(n, 1) = arr(y, 1)
                brr(n, 2) = arr(y, 2)
            End If
        Next
        GetArrTasks = brr
    End If
End Function

Function СистемаСчисления(Число As String, Optional СистемаИз As Byte = 10, Optional СистемаВ As Byte = 10)
    Dim d As Double
    Dim i As Integer
    Dim s As String
    Dim c As Variant
    Dim z As Long
    Dim k As Byte
     
    c = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
     
    If Число = "0" Then
       СистемаСчисления = "0"
    Else
        'преобразование цифры в число
        d = 0
        For i = 1 To Len(Число)
            s = Mid(UCase(Число), i, 1)
             
            k = 0
            Do
                If s = c(k) Then
                    d = d + k * СистемаИз ^ (Len(Число) - i)
                    Exit Do
                End If
                k = k + 1
                If k > UBound(c) Then Exit Do
            Loop
        Next
         
        'преобразование числа в цифру
        s = ""
        For i = Val(Log(d) / Log(СистемаВ)) To 0 Step -1
            z = СистемаВ ^ i
            k = Int(d / z)
             
            s = s & c(k)
            d = d - k * z
        Next
         
        СистемаСчисления = s
    End If
End Function