Optimization looping

Due to Excel Solver cannot let constraint: p1<p2, I only used to looping for optimization. There are need more time to solve it by grid search method. Anyone can help me to improve below code so that reduce time? Thanks...

Sub grid_search()

'Optimization for parameter
Dim max As Single, s1 As Integer, s2 As Integer, p1 As Integer, p2 As Integer, opt1 As Single, opt2 As Single, count As Integer
ReDim arr(range("p1_start") To range("p1_end"), range("p2_start") To range("p2_end"))

StartTime = Timer
Application.ScreenUpdating = False
max = -100: opt1 = 0: opt2 = 0: count = 0

    s1 = Application.max((UBound(arr, 1) - LBound(arr, 1)) \ range("p1_step"), 1)
    s2 = Application.max((UBound(arr, 2) - LBound(arr, 2)) \ range("p2_step"), 1)
    If UBound(arr, 1) = LBound(arr, 1) Then p1 = LBound(arr, 1): GoTo p2_loop Else 'for constant parameter1
    For p1 = LBound(arr, 1) To UBound(arr, 1) Step s1
p2_loop:
    If UBound(arr, 2) = LBound(arr, 2) Then p2 = LBound(arr, 2): GoTo run_result Else 'for constant parameter2
    For p2 = LBound(arr, 2) To UBound(arr, 2) Step s2
run_result:
    If p1 < p2 Then
        range("p1_optz") = p1
        range("p2_optz") = p2
        count = count + 1
        If range("result") >= max Then
            max = range("result")
            opt1 = p1
            opt2 = p2
        End If
    End If
    If UBound(arr, 2) = LBound(arr, 2) Then GoTo p1_loop Else
    Next p2
p1_loop:
    If UBound(arr, 1) = LBound(arr, 1) Then GoTo end_loop Else
    Next p1
end_loop:

Application.ScreenUpdating = True

'record optimizated parapmeters and result
range("result").Offset(-2, 0) = opt1
range("result").Offset(-1, 0) = opt2
range("result").Offset(1, 0) = count
range("result").Offset(2, 0) = Format(Timer - StartTime, "00.000")

End Sub