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

[RAN.]

Игорь, а ты себя не перехитрил?
может так

.Columns(6).SpecialCells(12).Copy Sheets("Викладачі").[M3]  
.Columns(27).SpecialCells(12).Copy Sheets("Викладачі").[L3]

[Hugo121]

Да, точно, так проще

[Automat]

спасибо, работает ....

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

Можно ещё перебором строк или массива выбрать, но банально

Неудобно просить, но можете еще написать тот же перебор циклом For с условиями If ?.... у меня с vba всё плохо..

И еще, после фильтра, перед копированием, как добавить условие Если в столбце АА повторяется фамилия, то просумировать ячейки столбца F напротив фамилии ?

PS. модераторы пофиксите плз название темы, вместо Н - Р

[Hugo121]

Через "For с условиями If" быстро так. Но выбираются только данные, без форматов. Зато быстро.
Если идти циклом по листу - то можно копировать с форматом, но это в 40 раз дольше.

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

    a = Sheets("Звіт").[A1].CurrentRegion.Value
    ReDim b(1 To UBound(a), 1 To 2)
    
    For i = 1 To UBound(a)
        If a(i, 2) = "Дипл.Пр. Керівництво" Then
            If a(i, 17) >= 20 Then
                If a(i, 24) = "СІ_51" Then
                    ii = ii + 1
                    b(ii, 1) = a(i, 27)
                    b(ii, 2) = a(i, 6)
                End If
            End If
        End If
    Next

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

End Sub

Для ускорения цепочку из If-Then нужно строить от менее часто встречающегося к более часто встречающемуся.
Чтоб негодные чаще откидывало сразу, без дальнейших проверок.

[Automat]

Hugo121, спасибо, очень помогли

Подскажите, если после фильтра или цикла, перед копированием, как добавить условие Если в столбце АА повторяется фамилия, то просумировать значения ячеек столбца F напротив фамилии (чтоб фамилии в новой табличке не повторялись)?

[Hugo121]

Тогда перед
ii = ii + 1
проверяем фамилию по словарю.
Если в словаре нет, то тогда
ii = ii + 1
заносим фамилию и ii в словарь, данные в массив.
Если в словаре уже есть, то извлекаем из словаря ii, в массиве b ищем нужное поле и суммируем.

Вслепую попробуйте так (файл дома есть, вечером проверю - а на сервере файл уже Вами удалён...)

Option Explicit

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

    a = Sheets("Звіт").[A1].CurrentRegion.Value
    ReDim b(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, 1)) Then
                            ii = ii + 1
                            .Item(a(i, 1)) = ii
                            b(ii, 1) = a(i, 27)
                            b(ii, 2) = a(i, 6)
                        Else
                            t = .Item(a(i, 1))
                            b(t, 2) = b(t, 2) + a(i, 6)
                        End If
                    End If
                End If
            End If
        Next
    End With

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

End Sub

P.S. Файл дома не нашёл - уже удалён... (

[Automat]

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

P.S. Файл дома не нашёл - уже удалён... (

макрос протестил чтото нетак

[Hugo121]

Ну так и есть - вслепую делать...
Всюду вместо a(i, 1) нужно a(i, 27) (т.е. в словарь заносим фамилию, а она в 27-м столбце):

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

    a = Sheets("Звіт").[A1].CurrentRegion.Value
    ReDim b(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
                End If
            End If
        Next
    End With

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

End Sub

[IgorGO]

вот здорово!

еще 10-15 соообщений и я начну понимать о чем речь...

[DiemonStar]

еще 10-15 соообщений и я начну понимать о чем речь...

да вроде всё и так понятно: скопировать уникальные значения из одного столбца на другую страницу и туда же сумму соответствующих значений из другого столбца... и всё это из исходной таблицы отфильтрованной по двум условиям) в общем-то, ничего нового...