Падение быстродействия в макросе

[skif93]

При открытии книги время выполнения макроса: 1797
Все последующие запуски:
4890
4859
4860
4953
Объясните пожалуйста где грабли?
Прошу сильно не пинать - с VBA на Вы.
Заранее спасибо.

[EducatedFool]

Проблема в строках

Do While Worksheets("Салоны").Cells(nRow, 1).Value <> ""
Do While Worksheets("СтрахованиеТранспорта").Cells(nRow, 10).Value<> ""
        Do While (Worksheets("Салоны").Cells(nRow, 3).Value = sVid And ...

Из-за перебора большого количества ячеек макрос начинает тормозить.
Возможно, какое-то условие не срабатывает, и макрос перебирает намного больше строк, чем надо.

Ну и вот это из макроса надо убрать:

Range("A" & nRow & ":E" & nRow).Select
                ramka
                Range("A" & nRow).Select

То же самое можно реализовать без выделения ячеек.

В общем, много всяких нюансов.
Но главное - надо сначала считывать весь диапазон ячеек с листа в массив, и потом уже обрабатывать значения массива.

Как раз вчера переделывал аналогичный макрос (который я писал год назад, когда только начинал знакомство с VBA). Применив вышеописанный способ, увеличил быстродействие кода в 9 раз.

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

PS: Вместо API-функции GetTickCount можно использовать встроенную в VBA функцию Timer (например, t=Timer)

[skif93]

Но при первом запуске все ок

[EducatedFool]

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

Но при первом запуске все ок

Вы называете удовлетворительным время работы макроса в 2 секунды?
В таком случае можно подождать и 5 сек...

Вообще, этот макрос после оптимизации может выполнить всю работу максимум за 0,5 сек.

А какой лист активен при открытии книги, и какой лист - при последующих запусках макроса?

[skif93]

Лист активен всегда один "Отчеты"
А 2 секунды это дома, а на работе 20-25
И ещё интересная штука - убрал из таблицы все данные не относящиеся к работе макроса и время работы макроса сократилось, но все равно первый запуск работает быстрее последующих.

[EducatedFool]

Сейчас попробую оптимизировать.
На сначала придётся разобраться, что этот макрос делает (на что уйдёт много времени)
Если есть Skype - звоните (это позволит сэкономить кучу времени)

Проблема очевидна - вы поочерёдно перебирали 33 тысячи ячеек.
Конечно, макрос будет тормозить.

Есть 3 варианта решения:
1) Задействовать встроенный автофильтр для фильтрации по дате, и обрабатывать только отфильтрованные строки
2) Считать весь диапазон ячеек в массив, и обрабатывать данные из массива.
3) Для формирования отчёта использовать сводные таблицы (в них я не разбираюсь, но по идее это позволило бы обойтись совсем без макросов)

[skif93]

Где бы литературу посмотреть по работе с массивами
А строк будет порядка 55тыс

[EducatedFool]

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

Проще всего обойтись совсем без макросов.
Сформируйте на новом листе сводную таблицу, которая будет брать данные непосредственно с листа СтрахованиеТранспорта
А начальную и конечную дату будете выбирать в самой сводной таблице.

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

Во вложении макрос формирует список на листе Салоны (этот лист скрыт), но не обрабатывает его - на основании этого списка уже построена сводная таблица, которую достаточно просто обновить:

Sub ПоСалону()
    StartTime = Timer: Application.ScreenUpdating = False
    dStart = CDbl(OT.[c1]): dEnd = CDbl(OT.[c2])
    OT.Visible = True: SA.UsedRange.Offset(1).Clear: SA.Visible = xlSheetHidden
    ST.Range("a7").AutoFilter Field:=6, Criteria1:=">" & dStart - 1, Operator:=xlAnd, Criteria2:="<" & dEnd + 1
    Dim ra As Range, ro As Range, SALONrow As Range
    Set ra = Intersect(ST.Cells.SpecialCells(xlCellTypeVisible), ST.UsedRange, ST.UsedRange.Offset(6))

    For Each ro In ra.EntireRow
        With ro
            If Trim(.Cells(12)) <> "" Then
                Set SALONrow = SA.Range("A" & SA.Rows.Count).End(xlUp).Offset(1).Resize(, 5)
                SALONrow.Value = Array(.Cells(4), .Cells(5), UCase(.Cells(16)), 1, .Cells(12))
            End If
        End With
    Next ro
    ST.ShowAllData     ' сброс автофильтра
    
    SA.UsedRange.Sort SA.[a2], xlAscending, SA.[b2], , xlAscending, SA.[c2], xlAscending, xlYes ' сортировка
    SV.PivotTables(1).PivotCache.Refresh ' обновление сводной таблицы
    
    Set ra = OT.Range("e65000").End(xlUp).Offset(1)
    ra = Now: ra.Next = FormatNumber(Timer - StartTime, 2) & " сек."
End Sub

Вариант с массивами в этом случае будет работать быстрее - считывание данных с листа в массив длится около 0,5 сек., плюс на всё остальное уйдёт примерно столько же времени.
Попробуйте этот вариант на досуге:

        Set ra = Intersect(ST.UsedRange, ST.UsedRange.Offset(6), ST.Columns("a:q"))
        'Debug.Print ra.Address
        arr = ra.Value ' считываем диапазон ячеек в массив
        ' arr - двумерный массив. обращаться к нему можно так: x=arr(5,3)

[skif93]

Спасибо большое за оперативность и примеры.
Завтра буду пробовать на "живых данных".