Ускорение макроса поиска и суммирования

[staniiislav]

Доброго времени суток Ув. форумчане
Помогите пожалуйста ускорить макрос:

Private Sub CommandButton2_Click()
If MsgBox("Проверить данные по операциям и корпусам?", vbYesNo, "ПРОВЕРКА") = vbNo Then Exit Sub
Dim i As Long, j As Long, jj As Long, ra As Range, ra1 As Range, ra2 As Range, c, firstAddress, s, ss
 
Application.Calculation = xlManual 'отключение пересчета формул
Application.ScreenUpdating = False ' отключение визуальной работы экрана в экселе
Application.EnableEvents = False ' отключение обработчика событий
On Error Resume Next
ActiveSheet.Unprotect Password:="0000"

ActiveSheet.Range("EL7:EL22").ClearContents ' очистка диапазона
For i = 7 To 20 ' счетчик по операциям
    For j = 5 To 37 ' счетчик по корпусам
        For Each ra In Range("E29:DX627").Rows ' счетчик по строкам
            Set ra1 = ra.Find(What:=Cells(i, 4), LookIn:=xlValues, LookAt:=xlWhole) ' ищим в строке (ra), оперцию (i)
                If Not ra1 Is Nothing Then ' проверяем, найдено ли искомое значение
                    Set ra2 = Range(Cells(ra1.Row, ra1.Column), Cells(ra1.Row, 128)) ' объявляем диапазон из строки
                    firstAddress = ra1.Address ' запоминаем адресс найденой ячейки
                        Do  ' цикл для проверки дубликатов
                            If Cells(ra1.Row, ra1.Column - 1) = j - 4 Then  ' проверяем, является ли найденая ячейка (смещеная на 1 столбец) равной корпусу
                                Cells(i, 142) = Cells(i, 142) + Sheets("Расценка").Cells(j, i - 2) ' суммируем найденое
                                Exit For ' выходим из счетчика For Each
                            End If  ' закрываем проверку по корпусу
                            ra1.Value = Cells(i, 4) ' присваеваем переменной имя операции
                            Set ra1 = ra2.FindNext(ra1) ' проверяем далее
                        Loop While Not ra1 Is Nothing And ra1.Address <> firstAddress ' закрываем цикл, если перемення ra1 не равна операции или адресс искомой ячейки равен адрессу проверяемой ячейки
                End If ' закрываем проверку искомого значения
        Next ra ' переходим к следующей строке
    Next j ' переходим к следующему корпусу
Next i  ' переходим к следующей операции

ActiveSheet.Protect Password:="0000", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
            AllowFiltering:=True, UserInterfaceOnly:=True
Application.EnableEvents = True ' включение обработчика событий
Application.ScreenUpdating = True   ' включение визуальной работы экрана в экселе
Application.Calculation = xlAutomatic   ' включение пересчета формул
MsgBox "Проверка завершена", vbInformation ' информационное сообщение
End Sub

суть макроса, поиск по 13 операция и в каждой операции может попасть энное количество корпусов (ну конечно не более 33), может 1 а может и 20 в месяц, и когда находит совпадение и по корпусу и по операции суммирует по операции (просто у у каждой операции разная расценка по корпусам, вот из-за чего такой геморой).
Макрос только дописал, работает нормально, но очень долго сек 40 на не заполненной таблице, а что будет когда заполнят... мин 5-10 нужно будет ждать проверки... если эксель не слетит(((
Вот, такая вот проблемка.
Заранее спасибо за внимание.
С Ув. Staniiislav

[EducatedFool]

А зачем макрос? Разве формулы не справятся с суммированием?

Чтобы ускорить макрос, считываем данные в массив, в массиве уже циклом проходим по значениям (сравнивая и суммируя их), потом выгружаем результаты на лист.
Уложитесь в 1 секунду по времени.

Примеров такого кода на форуме множество.

[staniiislav]

формулами было бы проще... попробовал через суммпроизв но перечисление двух условий + проверка этих двух условий 33 раза... форму огромная, вычислений уйма, соответственно подтормаживает.
На счет массивов, я об этом думал, но не совсем компетентен в данном вопросе, если можете дать пару ссылок, будет чудесно
П.С. сегодня заходил на ваш сайт, смотрел как мою задачу можно переменить к вашим примерам с массивами, если честно не догадался... точнее соображалка не сообразила ))))
Спасибо за ответ

[Hugo121]

Моя "соображалка" откровенно ленится представлять файл, вычитывая код.
Предчувствую, что можно сделать быстро, на массивы то уж точно можно перевести - но нужен файл.

[alex77755]

Думаю можно было бы применить комбинированный способ:
1. считать всё в массив. Типа M = Range("E29:DX627").
2. Загнать сочетания операций и корпусов в словарь.
3. Пройтись по массиву циклом с проверкой сочетаний из словаря, подсчётом и записью результатов в массив результатов(или в тот же словарь)
4. Выгрузить результаты на лист

[staniiislav]

Спасибо за ответы!
Взял за основу код EducatedFool
вот что получилось:

Private Sub CommandButton2_Click()
If MsgBox("Проверить данные по операциям и корпусам?", vbYesNo, "ПРОВЕРКА") = vbNo Then Exit Sub
Dim i As Long, j As Long, r As Long, arrS, СписокНомеровПодходящихСтрок

Application.Calculation = xlManual 'отключение пересчета формул
Application.ScreenUpdating = False ' отключение визуальной работы экрана в экселе
Application.EnableEvents = False ' отключение обработчика событий
On Error Resume Next
ActiveSheet.Unprotect Password:="0000"
ActiveSheet.Range("EL7:EL22").ClearContents ' очистка диапазона
    arrS = Range("E29:DX627").Value
    For i = 7 To 20 ' счетчик по операциям
        For j = 5 To 37 ' счетчик по корпусам
            For r = 1 To 31 Step 4
            СписокНомеровПодходящихСтрок = ArrAutofilter(arrS, r & "=" & j - 4, r + 1 & "=" & Cells(i, 4))
            If СписокНомеровПодходящихСтрок <> "" Then
                Cells(i, 142) = Cells(i, 142) + Sheets("Расценка").Cells(j, i - 2)
                Exit For
            End If
            Next r
        Next j
    Next i
ActiveSheet.Protect Password:="0000", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
            AllowFiltering:=True, UserInterfaceOnly:=True
Application.EnableEvents = True ' включение обработчика событий
Application.ScreenUpdating = True   ' включение визуальной работы экрана в экселе
Application.Calculation = xlAutomatic   ' включение пересчета формул
MsgBox "Проверка завершена", vbInformation ' информационное сообщение
End Sub

Function ArrAutofilter(ByRef arr, ParamArray args() As Variant) As String
Dim i As Long, x
    ' получает по ссылке массив ARR для фильтрации
    ' и список критериев фильтрации в формате "3=некий текст" (номер столбца, "=", искомое значение)
    ' возвращает текстовую строку - список номеров подходящих строк (через запятую)
    Dim Index As Long, OK As Boolean, ComparedColumn As Long, res As String

    If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical, "Ошибка в функции ArrAutofilter": Exit Function

    For Index = LBound(args) To UBound(args)    ' перебираем все параметры фильтрации
        If Not IsMissing(args(Index)) Then
            If GetAutofilterArgument(args(Index), ComparedColumn, res) Then
                If (ComparedColumn > UBound(arr, 2)) Or (ComparedColumn < LBound(arr, 2)) Then _
                   ArrAutofilter = ArrAutofilter & "В массиве нет столбца с номером " & ComparedColumn & vbNewLine
            Else
                ArrAutofilter = ArrAutofilter & "Неверно сформирована строка фильтрации: " & args(Index) & vbNewLine
            End If
        Else
            ArrAutofilter = ArrAutofilter & (Index + 1) & "-й аргумент фильтрации отсутствует" & vbNewLine
        End If
    Next Index
    If Len(ArrAutofilter) Then MsgBox ArrAutofilter, vbCritical, "Ошибка в функции ArrAutofilter": ArrAutofilter = "": Exit Function

    For i = LBound(arr, 1) To UBound(arr, 1)    ' перебираем все строки массива
        OK = True
        For Index = LBound(args) To UBound(args)    ' перебираем все параметры фильтрации
            x = GetAutofilterArgument(args(Index), ComparedColumn, res)    ' получаем параметры фильтрации
            ' Debug.Print "present", Index, ComparedColumn, res
            If Not (arr(i, ComparedColumn) Like res) Then OK = False: Exit For
        Next Index
        If OK Then ArrAutofilter = ArrAutofilter & "," & i
    Next i
    ArrAutofilter = Mid$(ArrAutofilter, 2)
End Function

Function GetAutofilterArgument(ByVal arg, ByRef col As Long, ByRef searchStr As String) As Boolean
Dim sCol
    col = 0: searchStr = ""
    If UBound(Split(arg, "=")) < 1 Then Exit Function    ' нет знака =
    sCol = Split(arg, "=")(0): If Len(sCol) = 0 Or Not sCol Like String(Len(sCol), "#") Then Exit Function  ' номер столбца не соответствует
    searchStr = Mid$(arg, Len(sCol) + 2): col = Val(sCol)
    If col > 0 Then GetAutofilterArgument = True
End Function

Данное чудо работает гораздо быстрее (сек 5)

[staniiislav]

Вот файлик, может еще быстрее макрос можно сделать (или я не правильно воспользовался функцией EducatedFool)?

на листе "Таблица" 31 календарный день, который будут заполнять
Условия для проверки:
каждая операция может иметь суммы нескольких корпусов (но не должна суммировать повторения по корпусам и операции, то есть для операции 201, 1 корпус не должен просуммировать все найденные 201=1, а только 201=1 + 201=2, и т.д. суммы берутся из листа "Расценка")

[staniiislav]

может не совсем понятен вопрос? кто подскажет пример решения данного вопроса?

[staniiislav]

вот так пока быстрее считает 10 сек:
на форуме нашел пример

Option Explicit

Sub find_()
    Dim s_&, InVal, cena_%, i&
    On Error Resume Next
    ActiveSheet.Range("EL7:EL22").ClearContents
    For i = 7 To 20
    s_ = Cells(i, 4)
    InVal = Range("E29:DX627").Value
    cena_ = fCena(InVal, s_)
    Cells(i, 142).Value = cena_
    Next i
End Sub

Function fCena(arr, cFind&)
On Error Resume Next
Dim i&, j&, jj&, k&, ra As Range
fCena = 0
For k = 1 To 33
jj = 0
    For i = 1 To UBound(arr, 1)
        For j = 2 To UBound(arr, 2)
            If arr(i, j) = cFind And arr(i, j - 1) = k Then
                Set ra = Sheets("Расценка").Range("D2:T2").Find(What:=cFind, LookIn:=xlValues, LookAt:=xlWhole)
                fCena = fCena + Sheets("Расценка").Cells(k + 4, ra.Column)
                jj = 1
                Exit For
            End If
        Next j
        If jj = 1 Then Exit For
    Next i
Next k
End Function

я конечно понимаю что простой макрос, но я учусь )))
Советы по усовершенствованию будут?

[nilem]

может, как-то так

Sub find_()
'Dim tm!: tm = Timer
Dim r As Range, adr As String, i&, j&, k&
Dim x: x = Range("D6:D22").Value
ReDim y(1 To UBound(x), 1 To 1)
With Range("E29:DV627")
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            Set r = .Find(What:=x(i, 1), LookAt:=xlWhole)
            If Not r Is Nothing Then
                adr = r.Address
                Do
                    If r(1, 0) > 0 Then
                        j = r(1, 0) + 4: k = i + 3
                        y(i, 1) = Sheets("Расценка").Cells(j, k).Value
                        Exit Do
                    End If
                    Set r = .FindNext(r)
                Loop While r.Address <> adr
            End If
        End If
    Next i
End With
Range("EL6").Resize(i - 1).Value = y
'MsgBox Timer - tm
End Sub