如何在VBA中动态选择固定行集的单列引用？

需求说明 #

我正在为公司同事制作报表，需复制单个场景数据粘贴至计算列来测试多场景。待复制内容为同一列内的多个固定行区域（如E30:E34、E37:E39等），仅需将列引用从E修改至AW（未来可能扩展）。现有循环复制粘贴代码已可运行，需实现rArray中列引用的动态切换，计划通过场景上方的复选框或输入框让VBA识别目标列。

现有代码 #

Sub CopyScenario()

    Dim rArray(1 To 22) As Range
    Dim tArray(1 To 22) As Range

'Set up ranges for selected scenario

    Set rArray(1) = Sheets("LMA").Range("E30:E34")
    Set rArray(2) = Sheets("LMA").Range("E37:E39")
    Set rArray(3) = Sheets("LMA").Range("E41")
    Set rArray(4) = Sheets("LMA").Range("E43:E44")
    Set rArray(5) = Sheets("LMA").Range("E47:E50")
    Set rArray(6) = Sheets("LMA").Range("E52")
    Set rArray(7) = Sheets("LMA").Range("E54")
    Set rArray(8) = Sheets("LMA").Range("E56:E57")
    Set rArray(9) = Sheets("LMA").Range("E59:E60")
    Set rArray(10) = Sheets("LMA").Range("E64:E66")
    Set rArray(11) = Sheets("LMA").Range("E69:E70")
    Set rArray(12) = Sheets("LMA").Range("E72")
    Set rArray(13) = Sheets("LMA").Range("E83:E87")
    Set rArray(14) = Sheets("LMA").Range("E89:E91")
    Set rArray(15) = Sheets("LMA").Range("E93:E95")
    Set rArray(16) = Sheets("LMA").Range("E99:E100")
    Set rArray(17) = Sheets("LMA").Range("E102:E103")
    Set rArray(18) = Sheets("LMA").Range("E106")
    Set rArray(19) = Sheets("LMA").Range("E111:E118")
    Set rArray(20) = Sheets("LMA").Range("E123:E124")
    Set rArray(21) = Sheets("LMA").Range("E126:E130")
    Set rArray(22) = Sheets("LMA").Range("E133:E135")
    
'Set ranges for calc info to be pasted in

    Set tArray(1) = Sheets("LMA").Range("C30")
    Set tArray(2) = Sheets("LMA").Range("C37")
    Set tArray(3) = Sheets("LMA").Range("C41")
    Set tArray(4) = Sheets("LMA").Range("C43")
    Set tArray(5) = Sheets("LMA").Range("C47")
    Set tArray(6) = Sheets("LMA").Range("C52")
    Set tArray(7) = Sheets("LMA").Range("C54")
    Set tArray(8) = Sheets("LMA").Range("C56")
    Set tArray(9) = Sheets("LMA").Range("C59")
    Set tArray(10) = Sheets("LMA").Range("C64")
    Set tArray(11) = Sheets("LMA").Range("C69")
    Set tArray(12) = Sheets("LMA").Range("C72")
    Set tArray(13) = Sheets("LMA").Range("C83")
    Set tArray(14) = Sheets("LMA").Range("C89")
    Set tArray(15) = Sheets("LMA").Range("C93")
    Set tArray(16) = Sheets("LMA").Range("C99")
    Set tArray(17) = Sheets("LMA").Range("C102")
    Set tArray(18) = Sheets("LMA").Range("C106")
    Set tArray(19) = Sheets("LMA").Range("C111")
    Set tArray(20) = Sheets("LMA").Range("C123")
    Set tArray(21) = Sheets("LMA").Range("C126")
    Set tArray(22) = Sheets("LMA").Range("C133")
    
'Copy paste loop thru ranges
    
    Dim i, j As Integer
    
    For i = 1 To 22
    rArray(i).Copy
    j = 0
        Do Until Sheets("LMA").Cells(21 + j, 21).Value = ""
            j = j + 1
        Loop
    tArray(i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next
    

End Sub

修改后的代码（支持动态列切换） #

Sub CopyDynamicScenario()
    Dim ws As Worksheet
    Dim targetCol As String
    Dim rowRanges As Variant
    Dim rArray(1 To 22) As Range
    Dim tArray(1 To 22) As Range
    Dim i As Integer
    
    ' 指定工作表
    Set ws = Sheets("LMA")
    
    ' 获取目标列（这里用输入框示例，可替换为复选框取值逻辑）
    targetCol = InputBox("请输入目标列的列名（如E、AW）：", "选择场景列", "E")
    If targetCol = "" Then Exit Sub ' 用户取消则退出
    
    ' 存储固定的行区域模板（仅保留行部分）
    rowRanges = Array( _
        "30:34", "37:39", "41", "43:44", "47:50", _
        "52", "54", "56:57", "59:60", "64:66", _
        "69:70", "72", "83:87", "89:91", "93:95", _
        "99:100", "102:103", "106", "111:118", "123:124", _
        "126:130", "133:135" _
    )
    
    ' 动态设置源数据区域（替换列名）
    For i = 1 To 22
        Set rArray(i) = ws.Range(targetCol & rowRanges(i - 1))
    Next i
    
    ' 目标粘贴区域（原代码逻辑保留，若需修改可同理动态调整）
    Set tArray(1) = ws.Range("C30")
    Set tArray(2) = ws.Range("C37")
    Set tArray(3) = ws.Range("C41")
    Set tArray(4) = ws.Range("C43")
    Set tArray(5) = ws.Range("C47")
    Set tArray(6) = ws.Range("C52")
    Set tArray(7) = ws.Range("C54")
    Set tArray(8) = ws.Range("C56")
    Set tArray(9) = ws.Range("C59")
    Set tArray(10) = ws.Range("C64")
    Set tArray(11) = ws.Range("C69")
    Set tArray(12) = ws.Range("C72")
    Set tArray(13) = ws.Range("C83")
    Set tArray(14) = ws.Range("C89")
    Set tArray(15) = ws.Range("C93")
    Set tArray(16) = ws.Range("C99")
    Set tArray(17) = ws.Range("C102")
    Set tArray(18) = ws.Range("C106")
    Set tArray(19) = ws.Range("C111")
    Set tArray(20) = ws.Range("C123")
    Set tArray(21) = ws.Range("C126")
    Set tArray(22) = ws.Range("C133")
    
    ' 复制粘贴循环（优化为直接赋值，比Copy/Paste更高效）
    For i = 1 To 22
        ' 保留原空值检查逻辑，不需要可删除
        Dim j As Integer
        j = 0
        Do Until ws.Cells(21 + j, 21).Value = ""
            j = j + 1
        Loop
        
        ' 直接赋值，避免剪贴板操作
        tArray(i).Resize(rArray(i).Rows.Count, rArray(i).Columns.Count).Value = rArray(i).Value
    Next i
    
    MsgBox "场景数据复制完成！", vbInformation
End Sub

关键修改点说明 #

• 动态列获取：用InputBox示例获取目标列，若要改成复选框，只需将targetCol赋值为复选框对应的列名（比如targetCol = IIf(CheckBox1.Value, "E", "AW")）。
• 行模板分离：把固定的行区域提取到数组rowRanges中，通过拼接目标列名动态生成源数据区域，避免重复写大量Range代码，后续扩展行区域也更方便。
• 效率优化：将Copy/PasteSpecial替换为直接赋值，减少剪贴板依赖，运行更快更稳定。
• 代码可读性提升：新增工作表对象变量ws，避免重复调用Sheets("LMA")，逻辑更清晰。

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