请求优化Excel多场景循环VBA代码（替代重复操作）

我是VBA新手，当前用Macro1处理7个场景时重复了7次相同操作，代码冗余度极高。尝试用Macro2通过循环优化，但逻辑出错，需要实现高效循环：从指定单元格读取场景值，计算后将结果返回至对应单元格的紧邻下方。

当前冗长脚本（Macro1） #

Sub Macro1()

    Dim X As Worksheet
    Dim Y As Worksheet
    Set X = Sheets("Scenarios")
    Set Y = Sheets("Portfolio Model")
    
    'Run Flat Scenarios
    X.Select
    Range("M2").Select
    If Range("M2") = "N" Then Range("M2").Value = "Y" Else Range("M2").Value = "Y"
                
    '#1 Flat Scenario
    Y.Select
    Range("GO8").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP8").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
                
    '#2 Flat Scenario
    Y.Select
    Range("GO9").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP9").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
                
    '#3 Flat Scenario
    Y.Select
    Range("GO10").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP10").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
                
    '#4 Flat Scenario
    Y.Select
    Range("GO11").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP11").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    
    '#5 Flat Scenario
    Y.Select
    Range("GO12").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP12").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    
    '#6 Flat Scenario
    Y.Select
    Range("GO13").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP13").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    
    '#7 Flat Scenario
    Y.Select
    Range("GO14").Select
        Selection.Copy
    Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Calculate
    Range("GK5").Select
        Selection.Copy
    Range("GP14").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    
End Sub

尝试的循环优化版本（Macro2） #

Sub Macro2()

    Dim X As Worksheet
    Dim Y As Worksheet
    Set X = Sheets("Scenarios")
    Set Y = Sheets("Portfolio Model")
    
    'Run Flat Scenarios
    X.Select
    Range("M2").Select
    If Range("M2") = "N" Then Range("M2").Value = "Y" Else Range("M2").Value = "Y"
            
    Dim j As Variant
    Dim jArray As Variant
    jArray = Array(0.085, 0.0875, 0.09, 0.0925, 0.095, 0.0975, 0.01)

    Dim i As Variant
    Dim iArray As Variant
    iArray = Array(1, 2, 3, 4, 5, 6, 7)
    
    For Each i In iArray
        Range("GK5").Copy
        Range("GP" & 7 + i).PasteSpecial xlValues
    
        For Each j In jArray
            Range("G3").Value = j
            Calculate
        Next
    Next

End Sub

优化后的解决方案 #

Macro2的核心问题是循环顺序颠倒：应该先给G3赋值场景值、计算，再将结果GK5复制到对应GP单元格；另外存在未明确工作表对象、冗余操作的问题。以下是修正后的高效代码：

Sub OptimizedMacro()
    Dim X As Worksheet
    Dim Y As Worksheet
    Dim scenarioValues As Variant
    Dim i As Integer
    
    ' 初始化工作表对象，避免Select/Activate
    Set X = Sheets("Scenarios")
    Set Y = Sheets("Portfolio Model")
    
    ' 简化M2赋值：无论当前值是什么，直接设为Y
    X.Range("M2").Value = "Y"
    
    ' 场景值数组（注意：原jArray最后一个值0.01疑似笔误，若应为0.1可自行修改）
    scenarioValues = Array(0.085, 0.0875, 0.09, 0.0925, 0.095, 0.0975, 0.01)
    
    ' 关闭屏幕刷新和自动计算，提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 循环处理7个场景
    For i = LBound(scenarioValues) To UBound(scenarioValues)
        ' 1. 将当前场景值写入G3
        Y.Range("G3").Value = scenarioValues(i)
        ' 2. 手动计算当前工作表
        Y.Calculate
        ' 3. 将GK5的值复制到对应GP单元格（行号从8开始，对应i=0到6）
        Y.Range("GK5").Copy
        Y.Range("GP" & 8 + i).PasteSpecial Paste:=xlPasteValues
    Next i
    
    ' 恢复系统设置
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

关键优化点： #

• 移除Select/Activate：直接通过工作表对象引用单元格，避免激活工作表带来的错误和性能损耗
• 修正循环逻辑：先赋值场景值→计算→复制结果，符合业务流程
• 提升运行效率：关闭屏幕刷新、临时切换手动计算，大幅加快循环速度
• 简化代码：用数组索引替代额外的iArray，减少冗余变量
• 明确对象归属：所有单元格操作都指定工作表对象，避免因当前激活表变化导致的错误

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