Discover new time-saving features in one game-changing release, ScreenConnect 6.0, based on partner feedback. New features include a redesigned UI, app configurations and chat acknowledgement to improve customer engagement!
Sub Workbook_Open()
If CheckSolver Then
'If Not Solver.AutoOpened Then Solver.Auto_open
SetSeparator
Else
solverResult = -1
End If
End Sub
Sub SetSeparator()
With Application
.DecimalSeparator = "."
.ThousandsSeparator = " "
.UseSystemSeparators = False
End With
End Sub
Function CheckSolverIntl() As Boolean
'' Adjusted for Application.Run() to avoid Reference problems with Solver
'' Adjusted for international versions of Excel
'' Peltier Technical Services, Inc., Copyright © 2008. All rights reserved.
'' Returns True if Solver can be used, False if not.
Dim bSolverInstalled As Boolean
Dim bAddInFound As Boolean
Dim iAddIn As Long
Const sAddIn As String = "solver.xla"
'' Assume true unless otherwise
CheckSolverIntl = True
On Error Resume Next
' check whether Solver is installed
bSolverInstalled = IsInstalled(sAddIn)
Err.Clear
If bSolverInstalled Then
' uninstall temporarily
bAddInFound = AddInInstall(sAddIn, False)
' check whether Solver is installed (should be false)
bSolverInstalled = IsInstalled(sAddIn)
End If
If Not bSolverInstalled Then
' (re)install Solver
bAddInFound = AddInInstall(sAddIn, True)
' check whether Solver is installed (should be true)
bSolverInstalled = IsInstalled(sAddIn)
End If
If Not bSolverInstalled Then
MsgBox "Solver not found. This workbook will not work.", vbCritical
CheckSolverIntl = False
End If
If CheckSolverIntl Then
' initialize Solver
Application.Run "Solver.xla!Solver.Solver2.Auto_open"
End If
On Error GoTo 0
End Function
Function IsInstalled(sAddInFileName As String) As Boolean
Dim iAddIn As Long
IsInstalled = False
For iAddIn = 1 To Application.AddIns.Count
With Application.AddIns(iAddIn)
If LCase$(.Name) = LCase$(sAddInFileName) Then
If .Installed Then
IsInstalled = True
End If
Exit For
End If
End With
Next
End Function
Function AddInInstall(sAddInFileName As String, bInstall As Boolean) As Boolean
Dim iAddIn As Long
For iAddIn = 1 To Application.AddIns.Count
With Application.AddIns(iAddIn)
If LCase$(.Name) = LCase$(sAddInFileName) Then
If .Installed <> bInstall Then
.Installed = bInstall
End If
AddInInstall = True ' True = add-in is listed
Exit For
End If
End With
Next
End Function
'Read more: Using Solver in Excel VBA http://peltiertech.com/Excel/SolverVBA.html#ixzz1BgigqVQ2
'Function CheckSolver() As Boolean
' '' Adjusted for Application.Run() to avoid Reference problems with Solver
' '' Peltier Technical Services, Inc., Copyright © 2007. All rights reserved.
' '' Returns True if Solver can be used, False if not.'
' Dim bSolverInstalled As Boolean
' '' Assume true unless otherwise
' CheckSolver = True
' On Error Resume Next
' ' check whether Solver is installed
' bSolverInstalled = Application.AddIns("Solver Add-In").Installed
' Err.Clear
' If bSolverInstalled Then
' ' uninstall temporarily
' Application.AddIns("Solver Add-In").Installed = False
' ' check whether Solver is installed (should be false)
' bSolverInstalled = Application.AddIns("Solver Add-In").Installed
' End If
' If Not bSolverInstalled Then
' ' (re)install Solver
' Application.AddIns("Solver Add-In").Installed = True
' ' check whether Solver is installed (should be true)
' bSolverInstalled = Application.AddIns("Solver Add-In").Installed
' End If
' If Not bSolverInstalled Then
' MsgBox "Solver not found. This workbook will not work.", vbCritical
' CheckSolver = False
' End If
' If CheckSolver Then
' ' initialize Solver
' Application.Run "Solver.xla!Solver.Solver2.Auto_open"
' End If
' On Error GoTo 0
'End Function
Public Sub SolveTheProblem()
Dim row As Integer, rowTarget As Integer, columnTarget As Integer
Dim cellTarget As String
Dim vars As String, leftSide As String, rightSide As String
Dim targetValue As String
Dim resultInt As Integer
solutionFound = False
targetValue = CStr(Cells(1, 1).Value)
targetValue = Replace(targetValue, ",", ".")
rowTarget = Cells(2, 1).Value
columnTarget = Cells(3, 1).Value
If columnTarget = 2 Then
cellTarget = "$B$" + CStr(rowTarget)
'vars = "$B$" + CStr(rowTarget) + ","
Else
cellTarget = "$C$" + CStr(rowTarget)
End If
vars = "$B$" + CStr(rowTarget) + ","
For row = 1 To 17
If Cells(row, 4).Value > 0 Then
vars = vars + "$B$" + CStr(row) + ","
End If
Next row
vars = Left(vars, Len(vars) - 1)
'SolverReset
Application.Run "Solver.xla!SolverReset"
'SolverOptions MaxTime:=100, Iterations:=400, Precision:=0.00001, AssumeLinear:= _
' False, StepThru:=False, Estimates:=1, Derivatives:=2, SearchOption:=1, _
' IntTolerance:=5, Scaling:=False, Convergence:=0.0001, AssumeNonNeg:=True
'Måste anropa Auto_Run så att Solver Add-In installeras???
'Application.Run "Solver.xla!Auto_Open"
Application.Run "Solver.xla!Solver.Solver2.Auto_open"
Application.Run "Solver.xla!SolverOptions", 1000, 400, 0.00001
'Application.Run "Solver.xla!SolverOptions", 1000, 400, 0.00001, False, False, _
' 1, 2, 1, 5, False, 0.0001, True
'SolverOk SetCell:=cellTarget, MaxMinVal:=3, ValueOf:=targetValue, ByChange:=vars
Application.Run "Solver.xla!SolverOk", cellTarget, 3, targetValue, vars
'SolverAdd CellRef:="$b$1:$b$16", Relation:=3, FormulaText:="0"
Application.Run "Solver.xla!SolverAdd", "$b$1:$b$17", 3, "0"
'SolverAdd CellRef:="$b$21", Relation:=1, FormulaText:="0.999"
'Application.Run "Solver.xla!SolverAdd", "$b$21", 1, "0.999"
Application.Run "Solver.xla!SolverAdd", "$b$22", 1, "0.999"
For row = 1 To 17
If Not row = rowTarget Then
If Cells(row, 4).Value > 0 Then
leftSide = "$C$" + CStr(row)
rightSide = "$D$" + CStr(row)
'SolverAdd CellRef:=leftSide, Relation:=2, FormulaText:=rightSide
Application.Run "Solver.xla!SolverAdd", leftSide, 2, rightSide
End If
End If
Next row
'SolverAdd CellRef:="$c$1", Relation:=2, FormulaText:="$C$1"
'SolverSolve
'SolverSolve userFinish:=True
'The results of the SolverSolve function include:
' 0 Solver found a solution. All constraints and optimality conditions are satisfied.
' 1 Solver has converged to the current solution. All constraints are satisfied.
' 2 Solver cannot improve the current solution. All constraints are satisfied.
' 3 Stop chosen when the maximum iteration limit was reached.
' 4 The Set Cell values do not converge.
' 5 Solver could not find a feasible solution.
' 6 Solver stopped at user's request.
' 7 The conditions for Assume Linear Model are not satisfied.
' 8 The problem is too large for Solver to handle.
' 9 Solver encountered an error value in a target or constraint cell.
' 10 Stop chosen when maximum time limit was reached.
' 11 There is not enough memory available to solve the problem.
' 12 Another Excel instance is using SOLVER.DLL. Try again later.
' 13 Error in model. Please verify that all cells and constraints are valid.
resultInt = Application.Run("Solver.xla!SolverSolve", True)
Cells(31, 2) = resultInt
'Equivalent to selecting options and clicking OK in the Solver Results dialog box that appears when the solution process is finished. The dialog box will not be displayed.
'VBA Syntax
'SolverFinish(KeepFinal:=, ReportArray:=)
'Macro Language Syntax
'=SOLVER.FINISH(keep_final, report_array)
'KeepFinal is the number 1 or 2 and specifies whether to keep or discard the final solution.
'If KeepFinal is 1 or omitted, the final solution values are kept in the changing cells.
'If KeepFinal is 2, the final solution values are discarded and the former values of the changing cells are restored.
If resultInt < 2 Then
Application.Run "Solver.xla!SolverFinish", 1
Else
Application.Run "Solver.xla!SolverFinish", 2
End If
End Sub
Public Function ShowTrial(xReason As Integer)
Dim MyMsg As String
Dim myWindowOpen As String
Dim x As Variant
Dim ModelProject As String
ModelProject = Range("[DavesAddins.xlam]Sheet1!a1").Value
myWindowOpen = Application.ActiveWorkbook.Name
Windows(ModelProject).Activate
MyMsg = "SolverResults Trial Output = "
'To run a function in another workbook :-
'ReturnValue = Application.Run("filename.xls!functionname")
'If it needs arguments :-ReturnValue = Application.Run("filename.xls!functionname", Arg1value, Arg2value)
Select Case xReason
Case 1:
MyMsg = MyMsg + "Function called (on every iteration) because the Show Iteration Results box in the Solver Options dialog was checked, OR function called because the user pressed ESC to interrupt the Solver."
Application.StatusBar = MyMsg
x = Application.Run("'" & ModelProject & "'!myStatusbar", MyMsg) 'how I do my logging (a local sub to status bar and logsheet
Windows(myWindowOpen).Activate
ShowTrial = False ' to display trial, or false to just continue
Case 2:
MyMsg = MyMsg + "Function called because the Max Time option in the Solver Options dialog was exceeded."
Application.StatusBar = MyMsg
x = Application.Run("'" & ModelProject & "'!myStatusbar", MyMsg)
Windows(myWindowOpen).Activate
ShowTrial = False ' to display trial, or false to just continue
Case 3:
MyMsg = MyMsg + "Function called because the Max Iterations option in the Solver Options dialog was exceeded."
Application.StatusBar = MyMsg
x = Application.Run("'" & ModelProject & "'!myStatusbar", MyMsg)
Windows(myWindowOpen).Activate
ShowTrial = False ' to display trial, or false to just continue
Case Else
MyMsg = MyMsg + " Code " & xReason & " not understood"
Application.StatusBar = MyMsg
x = Application.Run("'" & ModelProject & "'!myStatusbar", MyMsg)
Windows(myWindowOpen).Activate
ShowTrial = True ' to display trial, or false to just continue
End Select
End Function
Sub SolverHandler(xSolverSolve As Variant)
Dim myMsg As String
'Documentation here = http://www.pe.tamu.edu/wattenbarger/public_html/PETE%20685/Latest%20Excel%20Programs/mlvbaref.htm
Select Case xSolverSolve
Case 0: myMsg = "Solver found a solution. All constraints and optimality conditions are satisfied."
Case 1: myMsg = "Solver has converged to the current solution. All constraints are satisfied."
Case 2: myMsg = "Solver cannot improve the current solution. All constraints are satisfied."
Case 3: myMsg = "Stop chosen when the maximum iteration limit was reached."
Case 4: myMsg = "The Set Cell values do not converge."
Case 5: myMsg = "Solver could not find a feasible solution."
Case 6: myMsg = "Solver stopped at user's request."
Case 7: myMsg = "The conditions for Assume Linear Model are not satisfied."
Case 8: myMsg = "The problem is too large for Solver to handle."
Case 9: myMsg = "Solver encountered an error value in a target or constraint cell."
Case 10: myMsg = "Stop chosen when maximum time limit was reached."
Case 11: myMsg = "There is not enough memory available to solve the problem."
Case 12: myMsg = "Another Excel instance is using SOLVER.DLL. Try again later."
Case 13: myMsg = "Error in model. Please verify that all cells and constraints are valid."
Case Else: myMsg = "Not Sure..."
End Select
myStatusBar (myMsg)
End Sub
Sub setSolverOptions()
'xSolverOptions = SolverOptions(300, 100, 0.01, False, True, False, 1, 1, 0.05, False, 0.01, True)
If PhaseI Then
xSolverOptions = solveroptions(sMaxTime, sIterations, sPrecision, sAssumeLinear, sStepthru, sEstimates, sDerivatives, sSearchOption, sIntTolerance, sScaling, sConvergence, sAssumeNonNeg)
ElseIf PhaseII Then
xSolverOptions = solveroptions(sMaxTimePII, sIterationsPII, sPrecisionPII, sAssumeLinearPII, sStepthruPII, sEstimatesPII, sDerivativesPII, sSearchOptionPII, sIntTolerancePII, sScalingPII, sConvergencePII, sAssumeNonNeg)
Else
xSolverOptions = solveroptions(sMaxTimePIII, sIterationsPIII, sPrecisionPIII, sAssumeLinearPIII, sStepthruPIII, sEstimatesPIII, sDerivativesPIII, sSearchOptionPIII, sIntTolerancePIII, sScalingPIII, sConvergencePIII, sAssumeNonNeg)
End If
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Passing Credentials into a command line | 13 | 33 | |
Best prediction based on two lists of numbers in excel | 2 | 42 | |
Excel - click on a cell and have everything in another cell clear | 13 | 32 | |
Excl VBA Find last column in disjointed range selection | 18 | 21 |
Join the community of 500,000 technology professionals and ask your questions.