作者：Excel,Home
Sub 用vba代码添加模型信任和前期引用规划求解() Dim oWshell, i Set oWshell = CreateObject('WScript.Shell') Application.ScreenUpdating = False '信任对VBA工程对象模型的访问 oWshell.RegWrite 'HKEY_CURRENT_USER\Software\Microsoft\Office' & Application.Version & '\Excel\Security\AccessVBOM', 1, 'REG_DWORD' '信任对 VBA 项目的访问 With Application .SendKeys '~' .CommandBars.FindControl(ID:=3627).Execute End With AddIns('规划求解加载项').Installed = True With ThisWorkbook.VBProject For i = 1 To .References.Count If .References(i).Name = 'Solver' Then Exit Sub Else If i = .References.Count Then ThisWorkbook.VBProject.References.AddFromFile 'SOLVER.XLAM' End If End If Next i End With Application.ScreenUpdating = TrueEnd Sub二，常用函数
1，SolverReset
重置 “规划求解参数” 对话框中的所有单元格选定区域和约束
2，SolverOk 函数
定义基本求解器模型。相当于在'数据分析**“组中单击**“规划求解”，然后在'规划求解参数” | 对话框中指定 选项。
SolverOk ( SetCell、MaxMinVal、ValueOf、ByChange、Engine、EngineDesc )
SetCell 是 Variant 类型的可选参数(不要给单元格，给单元格地址)。引用活动工作表中的一个单元格。对应于' 规划求解参数 '对话框中的'设置 目标单元格 '框。
MaxMinVal 是 Variant 类型的可选参数。对应于'规划求解参数'对话框中 的'最大值'、最小值 和'值' 选项。
ValueOf 是 Variant 类型的可选参数。如果 MaxMinVal 为 3，则必须指定目标单元格匹配到的值。
ByChange 是 Variant 类型的可选参数（不要给单元格，给单元格地址）。将更改的单元格或单元格范围，以便在目标单元格中获得所需的结果。对应于'规划 求解参数' 对话框中的'通过 更改单元格' 框。
Engine 是 Variant 类型的可选参数。应用来求解问题的求解方法：2 表示单纯形 LP 方法，1 表示 GRG 非线性方法，或 3 表示演进式方法。对应于' 规划求解参数 “对话框中的'选择求解 方法” 下拉列表。
EngineDesc 是 Variant 类型的可选参数。另一种以字符串形式指定应用来求解问题的求解方法的方式：“单纯形 LP”、“GRG 非线性”或“演进式”。对应于' 规划求解参数 “对话框中的'选择求解 方法” 下拉列表。
3，SolverAdd 函数
向当前问题添加一个约束。相当于在'数据分析' 组中 单击'规划求解'，然后单击'规划求解参数'对话框中 | 的'添加'。
SolverAdd ( CellRef 、Relation、FormulaText )
CellRef 必需 Variant。对单元格或单元格区域的引用(给地址，别直接给单元格)，该引用构成约束条件的左边部分。
Relation 必需 Integer。约束左侧和右侧的算术关系。如果选择 4、5 或 6，则 CellRef 必须引用决策变量单元格，并且不应指定 FormulaText。
FormulaText 可选 Variant。约束的右侧。
4，SolverFinish 函数
指示 Microsoft Office Excel 如何处理结果，以及要在解决方案过程完成时生成哪种报表。
SolverFinish (KeepFinal、ReportArray、OutlineReports **** **** )KeepFinal 是 Variant 类型的可选参数。可取值为 1 或 2。如果 KeepFinal 为 1 或省略，则最终的解决方案值将保留在更改的单元格中，以替换任何以前的值。如果 KeepFinal 值为 2，最终解决方案值遭放弃，并还原原有值。
ReportArray 是 Variant 类型的可选参数。Excel 在求解器完成时生成的报表种类：
当使用“单工 LP”或“GRG 非线性求解”方法时，1 会创建一个“解答”报告，2 会创建一个“敏感度”报告，3 会创建一个“限制”报告。
如果使用的是演进式求解方法，1 表示生成“答案”报表，2 表示生成“总体”报表。
当 SolverSolve 返回 5 (规划求解找不到可行解) ，1 创建一个'可行报告'，2 创建一个Feasibility-Bounds报告。
当 SolverSolve 返回 7 时（不满足线性条件），1 会创建“线性”报告。
使用 Array 函数可指定要显示的报告，例如，ReportArray:= Array(1,3)。OutlineReports 是 Variant 类型的可选参数。可以是 True 或 False。如果 OutlineReports 为 False 或省略，则报告以'常规'格式生成，而不进行分级显示。如果 OutlineReports 值为 True，生成的报表包含对应于你为决策变量和限制输入的单元格范围的大纲显示组。
5，SolverSolve 函数
开始执行规划求解的求解过程。相当于单击 “规划求解参数” 对话框中的 “求解”。
SolverSolve ( UserFinish 、ShowRef)
UserFinish 可选 Variant。如果为 True，则返回结果，而不显示“规划求解结果”对话框。如果为 False 或忽略，则返回结果，并显示“规划求解结果”对话框。ShowRef 可选 Variant。可以将宏的名称作为字符串 (作为 ShowRef) 传递。之后，只要规划求解由于下列某个原因而暂停，便会调用此宏，而不是显示“显示试解”对话框。
ShowRef 宏必须具有签名 函数 名称 (Reason As Integer)。参数 Reason 是 从 1 到 5 的整数值：
由于选中 “规划求解选项” 对话框中的 “显示迭代结果” 框而在每次迭代时调用的函数，或者由于用户按 Esc 来中断规划求解而调用的函数。
由于超过 “规划求解选项” 对话框中的 “最长运算时间” 限制而调用的函数。
由于超过 “规划求解选项” 对话框中的 “迭代次数” 限制而调用的函数。
由于超过 “规划求解选项” 对话框中的 “最大子问题数” 限制而调用的函数。
由于超过 “规划求解选项” 对话框中的 “最大可行解数” 限制而调用的函数。
SolverSolve 返回值
如果尚未完整定义规划求解问题，则 SolverSolve 会返回 #N/A 错误值。否则，规划求解将会运行，并且 SolverSolve 返回与“规划求解结果”对话框中显示的消息相对应的整数值：
示例代码
Worksheets('Sheet1').ActivateSolverResetSolverOptions Precision:=0.001SolverOK SetCell:=Range('TotalProfit'), _ MaxMinVal:=1, _ ByChange:=Range('C4:E6')SolverAdd CellRef:=Range('F4:F6'), _ Relation:=1, _ FormulaText:=100SolverAdd CellRef:=Range('C4:E6'), _ Relation:=3, _ FormulaText:=0SolverAdd CellRef:=Range('C4:E6'), _ Relation:=4SolverSolve UserFinish:=False, ShowRef:='ShowTrial'SolverSave SaveArea:=Range('A33')
Function ShowTrial(Reason As Integer) MsgBox Reason ShowTrial = 0End Function已知A-C列，根据F-G列客户和金额，找到票号组合
先定义一个函数，操作规划求解
'1参数， 目标单元格'2参数, 目标值'3参数, 可变的单元格Function MySolver(targetRng As Range, _ targetValue, _ varRng As Range) Dim ssjg$, i targetRng.Formula = '=SUMPRODUCT(D$2:D$19*$C$2:$C$19)' SolverReset '重置规划求解 '设置基本规划求解参数 solverok SetCell:=targetRng.Address, MaxMinVal:=3, _ ValueOf:=targetValue, ByChange:=varRng.Address, _ Engine:=2 '添加约束 solveradd varRng.Address, 5 '执行，但是不显示规划求解对话框 SolverSolve UserFinish:=True '结果返回单元格 SolverFinish KeepFinal:=1 '判断下规划求解结果是否对 If targetRng.Value = targetValue Then '然后在去找对应的票号 For i = varRng.Row To varRng.Cells(varRng.Count, 1).Row If Range('d' & i).Value = 1 Then ssjg = ssjg & '/' & Range('b' & i).Value End If Next End If '清空d列,返回结果 Range('d1:d19').ClearContents MySolver = IIf(ssjg = '', '查无', Mid(ssjg, 2))End Function设置主函数
Sub result() Dim r, dic, rng As Range, i, arData, ssKey$ Set dic = CreateObject('Scripting.Dictionary') Application.ScreenUpdating = False r = Range('a65536').End(xlUp).Row arData = Range('a1').Resize(r, 3).Value For i = 2 To r '用二级字典记录每个客户的单元格范围 ssKey = arData(i, 1) If dic.Exists(ssKey) = False Then Set dic(ssKey) = CreateObject('Scripting.Dictionary') Set dic(ssKey) = Range('d' & i) Else Set dic(ssKey) = Union(dic(ssKey), Range('d' & i)) End If Next r = Range('f65536').End(xlUp).Row For i = 2 To r ssKey = Range('f' & i).Value If dic.Exists(ssKey) Then Set rng = dic(ssKey) Range('d1:d19').ClearContents Range('h' & i).Value = MySolver([d1], Range('g' & i).Value, rng) End If Next Application.ScreenUpdating = TrueEnd Sub联系客服
