VBA调用Solver规划求解约束被忽略、迭代结果异常问题咨询

问题现象 #

运行以下VBA代码实现无卖空约束的投资组合优化时，出现两类异常：

Sub getNoShortSalePortfolio()

Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet

Dim assetReturns As ListObject
Set assetReturns = ws.ListObjects("tblAssetReturns")

Dim numColumnsAssets As Long
numColumnsAssets = assetReturns.ListColumns.Count
    
Dim portfolioWeightsVector() As Variant
Dim activeCellAddress As Variant
Dim adjustableCellsAddress As String

activeCellAddress = ws.Range("noShortSale").Address
   
adjustableCellsAdress = activeCellAddress & ":" & Range(activeCellAddress).Offset(numColumnsAssets - 2, 0).Address

Range(adjustableCellsAdress).ClearContents

Solverreset

SolverOptions Precision:=0.0001, Iterations:=10, AssumeNonNeg:=True
SolverOk SetCell:=Range("noShortSaleMean"), MaxMinVal:=1, ByChange:=Range(adjustableCellsAdress) ', EngineDesc:="GRG Nonlinear"

SolverAdd CellRef:=Range(adjustableCellsAdress), Relation:=1, FormulaText:=1
SolverAdd CellRef:=Range("noShortSaleWeightSum"), Relation:=3, FormulaText:=1
SolverAdd CellRef:=Range("noShortSaleVola"), Relation:=2, FormulaText:=Range("portfolioVolaAssetShare")

SolverSolve UserFinish:=True
SolverFinish KeepFinal:=1
End Sub

异常表现：

• Solver仅迭代2次就返回全相等的解向量（当前场景为每个资产权重10%），不符合「权重总和小于等于100%」的预设约束
• 配置的「组合波动率匹配指定单元格预设值」约束完全不生效
  手动配置Solver参数可得到正确结果，初步判断为VBA侧的目标、约束定义存在错误。

排查方向 #

• 变量拼写硬错误：代码中定义可变单元格地址的变量名为adjustableCellsAddress，但后续赋值、传参时拼写为adjustableCellsAdress（Address漏写一个d），VBA会自动生成未初始化的新变体变量，导致传入Solver的可变单元格范围完全无效。
• 迭代阈值设置过低：SolverOptions中Iterations:=10数值过小，GRG非线性求解器未完成收敛就提前终止，返回无效的初始试探解。
• 约束定义存在漏洞：
  • 仅设置了权重和>=1的约束，未补充权重和<=1的限制，可行域本身不符合权重总和100%的要求
  • 所有传入Solver的单元格范围未显式绑定工作表，活动表切换时会出现引用错位，导致约束不生效
  • 未清理历史残留约束，多次运行代码会重复叠加无效约束，干扰求解逻辑
• 求解引擎未显式指定：代码注释掉了GRG非线性引擎的指定，部分环境下Solver会默认调用线性求解引擎，无法处理波动率这类非线性计算，直接返回不满足约束的结果。
• 冗余接口调用：SolverSolve执行完成后额外调用SolverFinish，会导致求解结果被意外重置。

修复后完整代码 #

Sub getNoShortSalePortfolio()
    Dim ws As Worksheet
    Set ws = ActiveWorkbook.ActiveSheet

    Dim assetReturns As ListObject
    Set assetReturns = ws.ListObjects("tblAssetReturns")

    Dim numColumnsAssets As Long
    numColumnsAssets = assetReturns.ListColumns.Count
    
    Dim adjustableCellsAddress As String
    Dim startCell As Range
    Set startCell = ws.Range("noShortSale")
    ' 修正变量拼写，所有范围显式绑定当前工作表
    adjustableCellsAddress = ws.Range(startCell, startCell.Offset(numColumnsAssets - 2, 0)).Address

    ws.Range(adjustableCellsAddress).ClearContents

    ' 重置Solver配置
    SolverReset
    ' 调大迭代次数上限，保留非负约束（对应无卖空要求）
    SolverOptions Precision:=0.0001, Iterations:=1000, AssumeNonNeg:=True
    ' 显式指定GRG非线性求解引擎
    SolverOk SetCell:=ws.Range("noShortSaleMean"), _
             MaxMinVal:=1, _
             ByChange:=ws.Range(adjustableCellsAddress), _
             Engine:=1 ' Engine:=1 对应GRG Nonlinear引擎

    ' 清理历史残留约束，避免重复叠加
    On Error Resume Next
    SolverDelete CellRef:=ws.Range(adjustableCellsAddress), Relation:=1
    SolverDelete CellRef:=ws.Range("noShortSaleWeightSum"), Relation:=2
    SolverDelete CellRef:=ws.Range("noShortSaleWeightSum"), Relation:=3
    SolverDelete CellRef:=ws.Range("noShortSaleVola"), Relation:=2
    On Error GoTo 0

    ' 重定义正确约束
    ' 1. 单个资产权重不超过100%
    SolverAdd CellRef:=ws.Range(adjustableCellsAddress), Relation:=1, FormulaText:=1
    ' 2. 权重总和严格等于100%，替代原逻辑中仅要求总和>=1的漏洞
    SolverAdd CellRef:=ws.Range("noShortSaleWeightSum"), Relation:=2, FormulaText:=1
    ' 3. 组合波动率等于预设目标值，直接传入目标值避免引用错位
    SolverAdd CellRef:=ws.Range("noShortSaleVola"), Relation:=2, FormulaText:=ws.Range("portfolioVolaAssetShare").Value

    ' 执行求解，移除冗余的SolverFinish调用
    SolverSolve UserFinish:=True
End Sub

验证注意事项 #

• 运行代码前需在VBA编辑器的「工具-引用」中勾选对应版本的Solver引用，否则接口调用会失败
• 确认所有用到的命名范围（noShortSale/noShortSaleMean/noShortSaleWeightSum/noShortSaleVola/portfolioVolaAssetShare）均定义在当前活动工作表，不存在跨表引用错位
• 若仍出现收敛失败问题，可适当调高迭代次数上限、收紧计算精度参数

内容的提问来源于stack exchange，提问作者T123