vba操作规划求解

vba操作规划求解

• 要前期引用
• 用到的函数
• • 1，SolverReset
  • 2，SolverOk 函数
  • 3，SolverAdd 函数
  • 4，SolverFinish 函数
  • 5，SolverSolve 函数
• 一个简单案例

要前期引用

要使用vba操作规划求解，需要添加引用Solver
Program Files\Microsoft Office\Office14\Library\SOLVER 子文件夹中的 Solver.xlam

可以用代码直接操作，需弹窗后点击信任对VBA工程对象模型的访问

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 = True
End Sub

用到的函数

1，SolverReset

重置 “规划求解参数” 对话框中的所有单元格选定区域和约束

2，SolverOk 函数

定义基本求解器模型。 相当于在"数据分析**“组中单击**“规划求解”，然后在"规划求解参数” | 对话框中指定 选项。
SolverOk ( SetCell、MaxMinVal、ValueOf、ByChange、Engine、EngineDesc )

• SetCell 是 Variant 类型的可选参数(不要给单元格，给单元格地址)。 引用活动工作表中的一个单元格。 对应于" 规划求解参数 "对话框中的"设置 目标单元格 "框。
• MaxMinVal 是 Variant 类型的可选参数。 对应于"规划求解参数"对话框中 的"最大值"、最小值 和"值" 选项。

MaxMinVal	指定
1	最大
2	最小化
3	匹配特定值

• 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。

Relation	算术关系
1	<=
2	=
3	>=
4	CellRef 引用的单元格必须具有整数的最终值。
5	CellRef 引用的单元格的最终值必须为 0 (0) 1。
6	CellRef 引用的单元格必须具有所有不同和整数的最终值。

• 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 的整数值：
  1. 由于选中 “规划求解选项” 对话框中的 “显示迭代结果” 框而在每次迭代时调用的函数，或者由于用户按 Esc 来中断规划求解而调用的函数。
  2. 由于超过 “规划求解选项” 对话框中的 “最长运算时间” 限制而调用的函数。
  3. 由于超过 “规划求解选项” 对话框中的 “迭代次数” 限制而调用的函数。
  4. 由于超过 “规划求解选项” 对话框中的 “最大子问题数” 限制而调用的函数。
  5. 由于超过 “规划求解选项” 对话框中的 “最大可行解数” 限制而调用的函数。

SolverSolve 返回值
如果尚未完整定义规划求解问题，则 SolverSolve 会返回 #N/A 错误值。 否则，规划求解将会运行，并且 SolverSolve 返回与“规划求解结果”对话框中显示的消息相对应的整数值：

返回值	消息
0	规划求解找到解。 满足所有约束和最优条件。
1	规划求解已收敛到当前解。 满足所有约束。
2	规划求解无法改进当前解。 满足所有约束。
3	当超过最大迭代次数限制时选择“停止”。
4	“目标单元格”值不收敛。
5	规划求解找不到可行解。
6	规划求解已根据用户的请求而停止。
7	不满足此 LP 规划求解需要的线性条件。
8	问题太大，规划求解无法处理。
9	规划求解在目标或约束单元格中遇到错误值。
10	当超过最长运算时间限制时选择“停止”。
11	内存不足，无法解决问题。
13	模型出错。 请验证所有单元格和约束是否有效。
14	规划求解在允许误差范围内找到整数解。 满足所有约束。
15	达到最大可行 [整数] 解数时选择“停止”。
16	达到最大可行 [整数] 子问题数时选择“停止”。
17	规划求解在概率上收敛于一个全局解。
18	所有变量都必须拥有上限和下限。
19	二进制或所有不同约束中的变量界限冲突。
20	变量上下限禁止全部可行解。

示例代码

Worksheets("Sheet1").Activate
SolverReset
SolverOptions Precision:=0.001
SolverOK SetCell:=Range("TotalProfit"), _
    MaxMinVal:=1, _
    ByChange:=Range("C4:E6")
SolverAdd CellRef:=Range("F4:F6"), _
    Relation:=1, _
    FormulaText:=100
SolverAdd CellRef:=Range("C4:E6"), _
    Relation:=3, _
    FormulaText:=0
SolverAdd CellRef:=Range("C4:E6"), _
    Relation:=4
SolverSolve UserFinish:=False, ShowRef:= "ShowTrial"
SolverSave SaveArea:=Range("A33")

Function ShowTrial(Reason As Integer)
  Msgbox Reason
  ShowTrial = 0
End 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 = True
End Sub

其他规划求解vba函数帮助可以看官方文档
https://docs.microsoft.com/zh-cn/office/vba/excel/concepts/functions/using-the-solver-vba-functions