如何在VBA Solver中嵌入目标函数公式并使用数组提速？

问题背景 #

需实现以下需求：

• 需求a：在Solver的SetCell参数中直接嵌入最大化目标的计算公式，而非引用单元格公式
• 需求b：用数组处理SetCell与ByChangingCells变量，提升运行效率

当前痛点：

• 现有通过单元格公式引用的代码处理1万行数据耗时超1小时，无法适配10万行的场景
• 尝试直接嵌入公式的代码报错：Error in model. Please verify that all cells and Constraints are valid. Perhaps some cells that are not Variable Cells are marked as Integer, Binary, or AllDifferent

现有可用代码 #

Option Explicit

Sub Solver_Test()
'
' Solver_Test Macro
'

Dim startTime As Single
Dim Output(2 To 11) As Variant
Dim Input1 As String
Dim arr As Variant
Dim i As Long
Dim Sh As Worksheet

Set Sh = ThisWorkbook.Worksheets("Sheet1")

   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   
   arr = Sh.Range("A1").CurrentRegion
   
   For i = 2 To UBound(arr, 1)
   
   Output(i) = Sh.Range("B" & i).Address
   Input1 = Sh.Range("C" & i).Address
   
   SolverReset
   
   SolverOk Output(i), 1, 0, Input1, 1
   
   SolverAdd Input1, 3, 0.1
   SolverAdd Input1, 1, 0.8

SolverSolve False

Next i

   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   Application.EnableEvents = True
   
Debug.Print Timer - startTime

'
End Sub

报错尝试代码 #

Option Explicit

Sub Solver_Test1()
'
' Solver_Test1 Macro
'

Dim startTime As Single
Dim Output(2 To 11) As Variant
Dim Input1 As String
Dim Input2 As String
Dim Input3 As String
Dim Input4 As String
Dim Input5 As String
Dim arr As Variant
Dim i As Long
Dim Sh As Worksheet

Set Sh = ThisWorkbook.Worksheets("Sheet1")

   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   
   arr = Range("A1").CurrentRegion
   
   For i = 2 To UBound(arr, 1)
   
   Input1 = Sh.Range("C" & i).Value
   Input2 = Sh.Range("D" & i).Value
   Input3 = Sh.Range("E" & i).Value
   Input4 = Sh.Range("F" & i).Value
   Input5 = Sh.Range("G" & i).Value
   
   Output(i) = (2.71828 ^ ((Input1 - Input2) * (0.5 * Input3 + 0.2 * Input4)) / (1 + 2.71828 ^ ((Input1 - Input2) * (0.5 * Input3 + 0.2 * Input4)))) * (Input1 - Input5)
   
   SolverReset
   
   SolverOk Output(i), 1, 0, Input1, 1
   
   SolverAdd Input1, 3, 0.9
   SolverAdd Input1, 1, 1

SolverSolve False

Next i

   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   Application.EnableEvents = True
   
Debug.Print Timer - startTime

'
End Sub

核心问题分析 #

1. 报错原因：

   • SolverOk的SetCell参数必须是单元格地址，不能直接传入计算结果；ByChangingCells参数同样需要单元格地址，而非单元格值（报错代码中Input1 = Sh.Range("C" & i).Value是错误写法）。
   • 直接传入计算值会导致Solver无法识别目标变量与可变单元格的关联逻辑，触发模型无效报错。

2. 效率瓶颈：

   • 循环中逐个读写单元格、重复调用SolverReset和单步求解，导致IO开销巨大；1万行的循环操作叠加Solver的单实例求解，耗时必然超标。

优化方案实现 #

方案1：嵌入公式到单元格+数组批量预处理 #

通过数组批量读取输入数据、批量写入目标公式，减少单元格交互次数，提升求解效率：

Option Explicit

Sub Solver_Optimized()
    Dim startTime As Single
    Dim ws As Worksheet
    Dim inputArr As Variant, targetArr As Variant
    Dim i As Long, lastRow As Long
    Dim targetRange As Range, changeRange As Range
    
    startTime = Timer
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 关闭Excel冗余功能
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .SolverUserFinish = True ' 关闭求解弹窗，避免人工交互
    End With
    
    ' 批量读取所有输入数据到内存数组
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    inputArr = ws.Range("A1:G" & lastRow).Value
    
    ' 批量生成目标公式字符串
    ReDim targetArr(2 To lastRow, 1 To 1)
    For i = 2 To lastRow
        ' 用Excel原生EXP函数替代硬编码的e值，精度更高
        targetArr(i, 1) = "=(EXP((C" & i & "-D" & i & ")*(0.5*E" & i & "+0.2*F" & i & "))/(1+EXP((C" & i & "-D" & i & ")*(0.5*E" & i & "+0.2*F" & i & "))))*(C" & i & "-G" & i & ")"
    Next i
    
    ' 批量写入公式到目标单元格
    ws.Range("B2:B" & lastRow).Formula = targetArr
    
    ' 循环执行Solver求解
    For i = 2 To lastRow
        Set targetRange = ws.Range("B" & i)
        Set changeRange = ws.Range("C" & i)
        
        SolverReset
        SolverOk SetCell:=targetRange.Address, MaxMinVal:=1, ValueOf:=0, ByChange:=changeRange.Address, _
            Engine:=1, EngineDesc:="GRG Nonlinear"
        SolverAdd CellRef:=changeRange.Address, Relation:=3, FormulaText:="0.1" ' 约束：>=0.1
        SolverAdd CellRef:=changeRange.Address, Relation:=1, FormulaText:="0.8" ' 约束：<=0.8
        SolverSolve UserFinish:=True
    Next i
    
    ' 恢复Excel功能
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .SolverUserFinish = False
    End With
    
    Debug.Print "总耗时：" & Round(Timer - startTime, 2) & "秒"
End Sub

方案2：进一步提速：复用Solver约束 #

如果每行的约束条件完全一致，可以仅初始化一次约束，后续循环仅更新目标和可变单元格，减少重复操作：

Option Explicit

Sub Solver_SuperOptimized()
    Dim startTime As Single
    Dim ws As Worksheet
    Dim inputArr As Variant, targetArr As Variant
    Dim i As Long, lastRow As Long
    Dim targetRange As Range, changeRange As Range
    
    startTime = Timer
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .SolverUserFinish = True
    End With
    
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    inputArr = ws.Range("A1:G" & lastRow).Value
    
    ' 批量写入目标公式
    ReDim targetArr(2 To lastRow, 1 To 1)
    For i = 2 To lastRow
        targetArr(i, 1) = "=(EXP((C" & i & "-D" & i & ")*(0.5*E" & i & "+0.2*F" & i & "))/(1+EXP((C" & i & "-D" & i & ")*(0.5*E" & i & "+0.2*F" & i & "))))*(C" & i & "-G" & i & ")"
    Next i
    ws.Range("B2:B" & lastRow).Formula = targetArr
    
    ' 初始化Solver约束（仅执行一次）
    SolverReset
    Set targetRange = ws.Range("B2")
    Set changeRange = ws.Range("C2")
    SolverOk SetCell:=targetRange.Address, MaxMinVal:=1, ValueOf:=0, ByChange:=changeRange.Address, _
        Engine:=1, EngineDesc:="GRG Nonlinear"
    SolverAdd CellRef:=changeRange.Address, Relation:=3, FormulaText:="0.1"
    SolverAdd CellRef:=changeRange.Address, Relation:=1, FormulaText:="0.8"
    SolverSolve UserFinish:=True
    
    ' 循环处理剩余行，仅更新目标和可变单元格
    For i = 3 To lastRow
        Set targetRange = ws.Range("B" & i)
        Set changeRange = ws.Range("C" & i)
        
        SolverOk SetCell:=targetRange.Address, MaxMinVal:=1, ValueOf:=0, ByChange:=changeRange.Address, _
            Engine:=1, EngineDesc:="GRG Nonlinear"
        SolverSolve UserFinish:=True
    Next i
    
    ' 恢复Excel功能
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .SolverUserFinish = False
    End With
    
    Debug.Print "总耗时：" & Round(Timer - startTime, 2) & "秒"
End Sub

关键优化点说明 #

1. 公式嵌入正确方式：

   • 必须将目标计算公式写入单元格（用数组批量写入减少IO开销），SolverOk的SetCell引用该单元格地址，而非直接传入计算值。
   • 使用Excel原生EXP()函数替代硬编码的2.71828，精度更高且符合规范。

2. 数组提速核心：

   • 一次性读取所有输入数据到内存数组，避免循环中反复读取单元格。
   • 批量写入目标公式到单元格，减少单单元格写入的IO开销。

3. Solver调用优化：

   • 启用SolverUserFinish:=True关闭求解弹窗，避免人工交互。
   • 约束条件一致时，仅初始化一次约束，后续循环仅更新目标和可变单元格，减少SolverAdd的调用次数。

额外建议 #

• 若10万行数据仍无法满足性能需求，建议拆分数据为多个批次（比如每1万行一批），分批次执行，避免内存溢出。
• 考虑使用OpenSolver（免费开源的Excel求解器插件），其批量求解效率远超原生Solver，支持VBA调用。

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