如何优化STLS_Sensitivity宏，实现动态GoalSeek及批量列迭代？

核心需求实现 #

以下代码实现了批量列迭代、参数动态化的GoalSeek敏感度分析，完全覆盖你提出的操作逻辑：

Sub STLS_Sensitivity_Optimized()
    ' --------------------------
    ' 动态参数区 - 可根据需求修改
    ' --------------------------
    Dim goalSeekTarget As Double: goalSeekTarget = 1000000 ' GoalSeek目标值
    Dim coefficientX As Double: coefficientX = 1.05 ' 迭代系数
    Dim startRow As Long: startRow = 57 ' 复制起始行
    Dim endRow As Long: endRow = 213 ' 复制结束行
    Dim adjustCellAddr As String: adjustCellAddr = "E140" ' 调整单元格基准地址
    Dim targetCellAddr As String: targetCellAddr = "E161" ' 目标单元格基准地址
    Dim resultOffset1 As Long: resultOffset1 = 1 ' 初始结果行偏移（E213→E214）
    Dim iterRowOffset1 As Long: iterRowOffset1 = 3 ' 第一次迭代行偏移（E213→E216）
    Dim iterRowOffset2 As Long: iterRowOffset2 = 6 ' 第二次迭代行偏移（E213→E219）
    
    Dim ws As Worksheet
    Dim currentCol As Long
    Dim lastCol As Long
    Dim adjustCell As Range
    Dim targetCell As Range
    Dim copyRange As Range
    Dim resultCell1 As Range
    Dim iterCell1 As Range
    Dim resultCell2 As Range
    Dim iterCell2 As Range
    Dim resultCell3 As Range
    
    Set ws = ActiveSheet ' 可改为指定工作表，如ThisWorkbook.Worksheets("Sheet1")
    lastCol = ws.Cells(startRow, ws.Columns.Count).End(xlToLeft).Column
    
    ' 遍历所有行57有值的列
    For currentCol = 5 To lastCol ' 从E列（第5列）开始，可按需调整起始列
        If Not IsEmpty(ws.Cells(startRow, currentCol)) Then
            ' 1. 初始操作：复制当前列指定范围，执行GoalSeek
            Set copyRange = ws.Range(ws.Cells(startRow, currentCol), ws.Cells(endRow, currentCol))
            copyRange.Copy
            copyRange.PasteSpecial xlPasteValues ' 仅粘贴值
            
            Set adjustCell = ws.Cells(Range(adjustCellAddr).Row, currentCol)
            Set targetCell = ws.Cells(Range(targetCellAddr).Row, currentCol)
            Set resultCell1 = ws.Cells(endRow + resultOffset1, currentCol)
            
            ' 执行GoalSeek并记录结果
            If targetCell.GoalSeek(Goal:=goalSeekTarget, ChangingCell:=adjustCell) Then
                resultCell1.Value = adjustCell.Value
            Else
                resultCell1.Value = "GoalSeek失败"
            End If
            
            ' 2. 第一次迭代：生成迭代值，重复GoalSeek
            Set iterCell1 = ws.Cells(endRow + iterRowOffset1, currentCol)
            Set resultCell2 = ws.Cells(endRow + iterRowOffset1 + 1, currentCol)
            iterCell1.Value = ws.Cells(endRow, currentCol).Value * coefficientX
            
            ' 同步迭代值到计算范围
            ws.Cells(endRow, currentCol).Value = iterCell1.Value
            copyRange.Copy
            copyRange.PasteSpecial xlPasteValues
            
            If targetCell.GoalSeek(Goal:=goalSeekTarget, ChangingCell:=adjustCell) Then
                resultCell2.Value = adjustCell.Value
            Else
                resultCell2.Value = "GoalSeek失败"
            End If
            
            ' 3. 第二次迭代：生成迭代值，重复GoalSeek
            Set iterCell2 = ws.Cells(endRow + iterRowOffset2, currentCol)
            Set resultCell3 = ws.Cells(endRow + iterRowOffset2 + 1, currentCol)
            iterCell2.Value = iterCell1.Value * coefficientX
            
            ' 同步迭代值到计算范围
            ws.Cells(endRow, currentCol).Value = iterCell2.Value
            copyRange.Copy
            copyRange.PasteSpecial xlPasteValues
            
            If targetCell.GoalSeek(Goal:=goalSeekTarget, ChangingCell:=adjustCell) Then
                resultCell3.Value = adjustCell.Value
            Else
                resultCell3.Value = "GoalSeek失败"
            End If
            
            ' 清除剪贴板，避免弹窗干扰
            Application.CutCopyMode = False
        End If
    Next currentCol
    
    MsgBox "敏感度分析完成", vbInformation
End Sub

关键优化点说明 #

• 参数动态化：所有核心参数（目标值、系数、单元格位置等）集中在代码开头，无需修改核心逻辑即可快速调整需求
• 批量列处理：自动遍历行57有值的所有列，无需手动逐列执行操作
• 模块化逻辑：复制、GoalSeek、迭代操作封装为标准化流程，便于后续扩展更多迭代次数
• 错误标记：对GoalSeek失败的场景进行明确标记，避免结果缺失
• 性能优化：仅粘贴值、及时清除剪贴板，减少内存占用与不必要的交互

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