Как заставить мой код занимать меньше времени на обработку?

Question

В основном у меня есть следующий код VBA, который я применяю к 5000+ строкам, и это занимает довольно много времени, и я хотел знать, есть ли способ заставить его работать немного быстрее.Я в основном пытаюсь оптимизировать значения для x и y и запускать их в каждой строке.

Заранее спасибо

Sub maximise(ByRef x As Range, ByRef y As Range)

    Dim ypos1 As Double, ypos2 As Double, yneg1 As Double, yneg2 As Double
    Dim xpos As Double, xneg As Double

    x = 0.01
    ypos1 = y.Value2
    ypos2 = ypos1

    ActiveSheet.Calculate

    Do While ypos2 - ypos1 >= 0
        ypos1 = y.Value2
        xpos = x.Value2
        x.Value2 = x.Value2 + 0.01
        ActiveSheet.Calculate
        ypos2 = y.Value2
    Loop

    ActiveSheet.Calculate

    x = -0.01
    yneg1 = y.Value2
    yneg2 = yneg1

    ActiveSheet.Calculate

    Do While yneg2 - yneg1 >= 0
        yneg1 = y.Value2
        xneg = x.Value2
        x.Value2 = x.Value2 - 0.01
        ActiveSheet.Calculate
        yneg2 = y.Value2
    Loop

    ActiveSheet.Calculate

    If ypos1 > yneg1 Then
        x.Value2 = xpos
    Else
        x.Value2 = xneg
    End If

    ActiveSheet.Calculate

End Sub

Answer 1

Не изменяя свой код, вы можете попробовать отключить обновление экрана

    Sub maximise(ByRef x As Range, ByRef y As Range)

Application.ScreenUpdating = False

Dim ypos1 As Double, ypos2 As Double, yneg1 As Double, yneg2 As Double
Dim xpos As Double, xneg As Double

x = 0.01
ypos1 = y.Value2
ypos2 = ypos1

ActiveSheet.Calculate

Do While ypos2 - ypos1 >= 0
   ypos1 = y.Value2
   xpos = x.Value2
   x.Value2 = x.Value2 + 0.01
   ActiveSheet.Calculate
   ypos2 = y.Value2
Loop

ActiveSheet.Calculate

x = -0.01
yneg1 = y.Value2
yneg2 = yneg1

ActiveSheet.Calculate

Do While yneg2 - yneg1 >= 0
   yneg1 = y.Value2
   xneg = x.Value2
   x.Value2 = x.Value2 - 0.01
   ActiveSheet.Calculate
   yneg2 = y.Value2
Loop

ActiveSheet.Calculate

If ypos1 > yneg1 Then
    x.Value2 = xpos
Else
    x.Value2 = xneg
End If

ActiveSheet.Calculate

Application.ScreenUpdating = True

End Sub