I have written a macro that is essentially solving for the intersection between a line and a high order polynomial function. I am using the Solver add in to determine the solutions but depending on the set up of the sheet this needs to run 100's of times and it is taking an extremely long time (15-20 minutes).

I have added any optimization techniques I know of (disabling screen updating, events, statusbar, etc) and have run out of ideas. here is the section of code I need help with:

Code:

```
Sub SolverCoping()
'solves for beam elevations to set haunch thickness to
Application.DisplayStatusBar = False
Dim i, j, s, t, k As Integer
Dim PerpIntersect, PerpLine, Deck As String
Dim NumSpans As Integer
Dim NumBeams As Integer
Dim db As Integer
Dim LoopCounter As Integer
Dim LoopMax As Integer
Dim AllowCope As Double
Dim AllowCopeR As String
Dim MinCope As String
Dim TopBeam As String
Dim StartDeckElev As String
Dim count As Integer
Dim StartOffset As Integer
Sheet3.Select
NumBeams = Range("C7").Value
NumSpans = Range("C6").Value
Sheet7.Select
TopBeam = Range("I10").Offset((NumBeams + 5) * 11, 0).Address
StartDeckElev = Range("I10").Offset((NumBeams + 5) * 4, 0).Address
PerpIntersect = Range("I10").Offset((NumBeams + 5) * 13, 0).Address
PerpLine = Range("I10").Offset((NumBeams + 5) * 12, 0).Address
Deck = Range("I10").Offset((NumBeams + 5) * 6, 0).Address
LoopMax = 3 * NumSpans * NumBeams * 12
LoopMax = LoopMax * 1.1 'adds 10% so the set up is 5% and the summary and charts are 5%
LoopCounter = Round(LoopMax * 0.05, 0) ' starts solver percentage at 5%
' db = "error"
'NumSpans = 1
For k = 0 To 2 'runs program multiple times do to iterative nature
If k = 0 Then MinCope = Range("T10").Offset((NumBeams + 5) * 18, 0).Address Else MinCope = Range("T10").Offset((NumBeams + 5) * 17, 0).Address
For s = 0 To NumSpans - 1 'loops through spans
For i = 0 To NumBeams - 1 'loops through beams
AllowCopeR = Range("G10").Offset((NumBeams + 5) * 17 + i, s * 15).Address
'top of beam solver code here~~~~~~~~~~~~~~
SolverReset
SolverOk SetCell:=Range(MinCope).Offset(i, s * 15).Address, MaxMinVal:=1, ValueOf:=0, ByChange:=Range(TopBeam).Offset(i, s * 15), _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverAdd CellRef:=Range(MinCope).Offset(i, s * 15).Address, Relation:=2, FormulaText:=AllowCopeR
SolverOk SetCell:=Range(MinCope).Offset(i, s * 15).Address, MaxMinVal:=1, ValueOf:=0, ByChange:=Range(TopBeam).Offset(i, s * 15), _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverSolve (True)
LoopCounter = LoopCounter + 1
'Application.StatusBar = LoopCounter & " of " & LoopMax & ", " & Format(LoopCounter / LoopMax, "0%") & " of Calculations Complete: "
If k = 2 Then
'db = "error"
End If
'~~~~~~~~~~~~~~~~~Start Perpendicular intersect~~~~~~~~~~~~~~~~~
'If k = 2 Then GoTo skipPerp
For t = 0 To 10 'loops through tenth points
' db = "error"
'intersection loop here~~~~~~~~~~~~~~~~~~~
If t = 0 Then StartOffset = 2 Else StartOffset = 0
SolverReset
SolverOk SetCell:=Range(PerpLine).Offset(i, t + s * 15).Address, MaxMinVal:=1, ValueOf:=0, ByChange:=Range(PerpIntersect).Offset(i, t + s * 15 - StartOffset).Address, _
Engine:=1, EngineDesc:="GRG Nonlinear"
' SolverDelete CellRef:=MinCope, Relation:=2, FormulaText:=AllowCopeR
SolverAdd CellRef:=Range(PerpLine).Offset(i, t + s * 15).Address, Relation:=2, FormulaText:=Range(Deck).Offset(i, t + s * 15).Address
SolverOk SetCell:=Range(PerpLine).Offset(i, t + s * 15).Address, MaxMinVal:=1, ValueOf:=0, ByChange:=Range(PerpIntersect).Offset(i, t + s * 15 - StartOffset).Address, _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverSolve (True)
LoopCounter = LoopCounter + 1
'shows progress in statusbar
' Application.StatusBar = LoopCounter & " of " & LoopMax & ", " & Format(LoopCounter / LoopMax, "0%") & " of Calculations Complete: "
' db = "error"
Next
'~~~~~~~~~~~~~~~~~end Perpendicular intersect~~~~~~~~~~~~~~~~~~~~
skipPerp:
' db = "error"
Next
' db = "error"
Range(Range("M10").Offset((NumBeams + 5) * 19, s * 15), Range("M10").Offset((NumBeams + 5) * 19 + (NumBeams - 1), s * 15)).Copy
Range("N10").Offset((NumBeams + 5) * 19, s * 15).PasteSpecial (xlPasteValues)
Next
' db = Error
Next
Application.DisplayStatusBar = True
End Sub
```

I am running this in Excel 2016 on Windows 7

PC Specs:

Intel(R) Core(TM) i7-3770 CPU @ 3.40GHz, 3401 Mhz, 4 Core(s), 8 Logical Processor(s)

16 GB Ram

Thanks for any suggestions.