Hеализировать алгоритм на VBA

[Hugo121]

По трём.
И фильтрация в процессе.

[Automat]

Hugo121, спасибо, вы как всегда на высоте

Появился новый вопрос: как изменить код из поста 18, чтобы добавить условие для нескольких груп (к примеру для НД_31), чтоб выборка копировалась в столбец [P3] ?

If a(i, 2) = "Дипл.Пр. Керівництво" Then
If a(i, 17) > 20 Then
If a(i, 24) = "НД_31" Then

у меня на выходе всё копируется в один столбец M3.

[Hugo121]

Так выгрузка вот тут:

Sheets("Викладачі").[M3].Resize(ii, 2) = b

Думаю, если Вы хотите сразу отбирать несколько групп, то нужно сразу завести не один массив b, а несколько аналогичных, каждому свою переменную-счётчик, раскладывать данные по ним параллельно, затем выгружать каждую группу в свой диапазон. Сейчас попробую...
Упс, а тестить то опять не на чем...

Option Explicit

Sub Выборка_вариант3()
    Dim a(), i&, ii&, iii&, t&

    a = Sheets("Звіт").[A1].CurrentRegion.Value
    ReDim b(1 To UBound(a), 1 To 2)
    ReDim bb(1 To UBound(a), 1 To 2)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            If a(i, 2) = "Дипл.Пр. Керівництво" Then
                If a(i, 17) > 20 Then

                    If a(i, 24) = "СІ_51" Then
                        If Not .Exists(a(i, 27)) Then
                            ii = ii + 1
                            .Item(a(i, 27)) = ii
                            b(ii, 1) = a(i, 27)
                            b(ii, 2) = a(i, 6)
                        Else
                            t = .Item(a(i, 27))
                            b(t, 2) = b(t, 2) + a(i, 6)
                        End If
                    End If

                    If a(i, 24) = "НД_31" Then
                        If Not .Exists(a(i, 27)) Then
                            iii = iii + 1
                            .Item(a(i, 27)) = iii
                            bb(iii, 1) = a(i, 27)
                            bb(iii, 2) = a(i, 6)
                        Else
                            t = .Item(a(i, 27))
                            bb(t, 2) = bb(t, 2) + a(i, 6)
                        End If
                    End If

                End If
            End If
        Next
    End With

    With Sheets("Викладачі")
        .[M3].Resize(ii, 2) = b
        .[P3].Resize(iii, 2) = bb
    End With

End Sub

Можно вероятно код чуть упростить/сократить, например используя Select Case и одну подпрограмму по заполнению массивов, но так должно быть понятнее, что происходит - отбираем по двум условиям, а по третьему (в зависимости от a(i, 24) ) смотрим, в какой массив помещать данные.
Но вслепую - так что если что не так, то говорите.
P.S. Возможно, нужно для каждой группы делать свой словарь - это если возможны одинаковые фамилии в разных группах.

[Automat]

протестил, спасибо !

[Hugo121]

Попробовал - не ругалось.
Но две b забыл - заменил код выше (чтоб не плодить уродов...)
Правда, по второй группе вытягивает только
_Лісова 2
Не понял, правильно или нет - уж больно данных много... Но вроде правильно.

[Automat]

Сообщение от Hugo121

Но вроде правильно.

по первой групе всё ровно, а по второй както неправильно выбирает , должно быть как минимум 8 значений

[Hugo121]

8 значений? Какие строки?
Сам нашёл - я ведь говорил, что если фамилии дублируются, то нужно 2 словаря..

Вот с внешней процедурой (и уже с двумя словарями):

Sub Выборка_вариант3Prim()
    Dim a(), i&, ii&, iii&, oDict1, oDict2

    a = Sheets("Звіт").[A1].CurrentRegion.Value
    
    ReDim b(1 To UBound(a), 1 To 2)
    ReDim bb(1 To UBound(a), 1 To 2)

    Set oDict1 = CreateObject("Scripting.Dictionary")
    Set oDict2 = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(a)
        If a(i, 2) = "Дипл.Пр. Керівництво" Then
            If a(i, 17) > 20 Then

                Select Case a(i, 24)
                Case "СІ_51": toArr oDict1, b, a(i, 27), a(i, 6), ii
                Case "НД_31": toArr oDict2, bb, a(i, 27), a(i, 6), iii
                End Select

            End If
        End If
    Next

    With Sheets("Викладачі")
       If i > 0 Then .[M3].Resize(ii, 2) = b
       If ii > 0 Then .[P3].Resize(iii, 2) = bb
    End With

End Sub


Private Sub toArr(dd, arr, val_1, val_2, i)
    Dim t&
    If Not dd.Exists(val_1) Then
        i = i + 1
        dd.Item(val_1) = i
        arr(i, 1) = val_1
        arr(i, 2) = val_2
    Else
        t = dd.Item(val_1)
        arr(t, 2) = arr(t, 2) + val_2
    End If

End Sub

Теперь можно легко наращивать условия отбора по третьему параметру - только добавить массивы, словари и переменные, и одну строку условия.