Как оптимизировать макрос VBA

Question

Мне нужна ваша помощь в оптимизации этого макроса в Excel. Я использую его для получения данных для этикеток для химиотерапевтических препаратов в нашей больнице. Макрос работает нормально сейчас, но иногда генерация занимает много времени. Это некоммерческий проект, и, конечно, я не получаю никакой помощи от руководства. Буду благодарен за любое предложение или помощь.

Dim i, iLastRow, d As Integer
Dim date1, date2 As Date
Dim oLastRow As ListRow
Dim srcRow As Range
Dim date_tabela As Date
Dim ile_dawek As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.StatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
date1 = Worksheets("Program").Range("E2")
date2 = Worksheets("Program").Range("E3")
iLastRow = Worksheets("Program").ListObjects("Program").ListRows.Count + 6
For i = 7 To iLastRow
date_tabela = Cells(i, 4).Value
ile_dawek = Cells(i, 11).Value 
    If date_tabela >= date1 And date_tabela <= date2 Then
        For d = 1 To ile_dawek
            Set srcRow = Worksheets("Program").ListObjects("Program").Range.Range(Cells(i - 5, 1), Cells(i - 5, 36))
            Set oLastRow = Worksheets("Etykiety").ListObjects("Etykiety_druk").ListRows.Add()
            srcRow.Copy
            oLastRow.Range.PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False

        Next
     End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = True
Application.EnableEvents = True
ActiveWorkbook.Save
End Sub

Answer 1

Один из способов ускорить выполнение - избежать повторного повторения одних и тех же значений в цикле.

Пример:

Worksheets("Program").ListObjects("Program").Range

Присвойте его переменной (пример:programRange) и используйте переменную для выбора поддиапазона. Вы можете сделать то же самое с выражением oLastRow.

Во-вторых, поскольку некоторые вычисления зависят от сравнения дат, вы можете избежать вычисления значений, которые вам не нужны, если тест не пройден. Вы можете установить 'ile_dawek' внутри оператора IF.

Конечно, есть и другие оптимизации, но они требуют большего анализа.

Конечно, делать назначения до цикла (ов).

Answer 2

Для оптимизации вашего кода есть несколько общих правил:
- использовать локальные переменные вместо полностью определенных ссылок
- объявляйте переменные с правильными типами, а не с вариантами
- в циклах переместите код за пределы цикла, который инвариантен к переменной цикла

Например, данные, которые вы копируете, инвариантны к циклу по количеству этикеток, которые вы хотите напечатать. Таким образом, вы копируете данные только один раз (в буфер обмена) и повторно используете их несколько раз.

Если вы посмотрите мое предложение по коду, вы обнаружите, что я не полностью следовал правилам; Вы должны указать точный тип для переменной oLabels .

Тогда был хорошо скрытый источник ошибки при использовании date_tabela = Cells(i, 4).Value Cells здесь зависят от контекста. Я заменил его на .Cells которые определяют контекст как Worksheet("Program") .

Сброс CutCopyMode просто косметический, вы можете сделать это один раз только в конце.

Код выглядит сейчас так:

Sub print_doses()
    Dim i As Integer, iLastRow As Integer
    Dim date1 As Date, date2 As Date
    Dim oLastRow As ListRow
    Dim srcRow As Range
    Dim date_tabela As Date
    Dim d As Integer, ile_dawek As Integer
    Dim oLabels

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False

    Set oLabels = Worksheets("Etykiety").ListObjects("Etykiety_druk").ListRows
    With Worksheets("Program")
        date1 = .Range("E2")
        date2 = .Range("E3")
        iLastRow = .ListObjects("Program").ListRows.Count + 6
        For i = 7 To iLastRow
            date_tabela = .Cells(i, 4).Value
            If date_tabela >= date1 And date_tabela <= date2 Then
                ile_dawek = .Cells(i, 11).Value
                Set srcRow = .ListObjects("Program").Range.Range(Cells(i - 5, 1), Cells(i - 5, 36))
                srcRow.Copy
                For d = 1 To ile_dawek
                    Set oLastRow = oLabels.Add()
                    oLastRow.Range.PasteSpecial xlPasteValuesAndNumberFormats
                Next
            End If
        Next i
        Application.CutCopyMode = False
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = ""
    Application.EnableEvents = True
    ActiveWorkbook.Save
End Sub

Answer 3

Одна быстрая вещь

Dim i, iLastRow, d As Integer
Dim date1, date2 As Date
Dim oLastRow As ListRow
Dim srcRow As Range
Dim date_tabela As Date
Dim ile_dawek As Integer

Переменные с несколькими объявлениями не имеют типа, только последняя - вам нужно

Dim i as long, iLastRow as long, d as long

Если вы не определили свою переменную, VBA объявит ее как вариант, то есть объекты:

Производительность Переменная, которую вы объявляете с типом Object, достаточно гибкая, чтобы содержать ссылку на любой объект. Однако, когда вы вызываете метод или свойство для такой переменной, вы всегда подвергаетесь позднему связыванию (во время выполнения). Для принудительного раннего связывания (во время компиляции) и повышения производительности объявите переменную с определенным именем класса или приведите ее к определенному типу данных.

Не объявляя переменные, вы могли бы платить штраф.