如何用VBA遍历Excel下拉列表组合并批量复制计算结果至新工作表？

问题说明 #

我有一个名为Output的工作表，其C2:C7区域包含6个数据验证下拉列表（总组合数216种）。每种组合会在C9:C12区域生成不同计算输出（计算逻辑依赖下拉值），需要将所有组合的结果复制到Summary工作表的指定区域。

之前尝试录制宏手动操作，效率极低，示例代码如下：

' Select dropdown boxes
Sheets("Output").Select
Range("C2").Select
ActiveCell.FormulaR1C1 = "A"
Range("C3").Select
ActiveCell.FormulaR1C1 = "D"
Range("C4").Select
ActiveCell.FormulaR1C1 = "F"
Range("C5").Select
ActiveCell.FormulaR1C1 = "H"
Range("C6").Select
ActiveCell.FormulaR1C1 = "J"
Range("C7").Select
ActiveCell.FormulaR1C1 = "M"

' Copy first row
Sheets("Summary").Select
Range("G2").Select
ActiveCell.FormulaR1C1 = "=Output!R[7]C[-4]"
Range("H2").Select
ActiveCell.FormulaR1C1 = "=Output!R[8]C[-5]"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=Output!R[9]C[-6]"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=Output!R[10]C[-7]"
Range("G2:J2").Select
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

' Change dropdown selection to match second row
Sheets("Output").Select
Range("C5").Select
ActiveCell.FormulaR1C1 = "I"

' Copy second row
Sheets("Summary").Select
Range("G3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=Output!R[6]C[-4]"
Range("H3").Select
ActiveCell.FormulaR1C1 = "=Output!R[7]C[-5]"
Range("I3").Select
ActiveCell.FormulaR1C1 = "=Output!R[8]C[-6]"
Range("J3").Select
ActiveCell.FormulaR1C1 = "=Output!R[9]C[-7]"
Range("G3:J3").Select
Selection.Copy
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

高效实现代码 #

以下代码会自动提取每个下拉列表的可选值，遍历所有组合并批量复制结果，全程无需手动操作：

Sub GenerateAllCombinations()
    Dim wsOutput As Worksheet, wsSummary As Worksheet
    Dim dropDownRanges As Variant, dropDownValues As Variant
    Dim comboCounts As Variant, currentCombo As Variant
    Dim totalCombos As Long, i As Long, rowNum As Long
    
    ' 关闭屏幕更新和事件，大幅提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 绑定目标工作表
    Set wsOutput = ThisWorkbook.Sheets("Output")
    Set wsSummary = ThisWorkbook.Sheets("Summary")
    
    ' 定义下拉列表所在单元格范围（C2到C7）
    dropDownRanges = Array("C2", "C3", "C4", "C5", "C6", "C7")
    ReDim dropDownValues(UBound(dropDownRanges))
    ReDim comboCounts(UBound(dropDownRanges))
    
    ' 提取每个下拉列表的可选值
    For i = LBound(dropDownRanges) To UBound(dropDownRanges)
        With wsOutput.Range(dropDownRanges(i)).Validation
            ' 如果下拉数据源是逗号分隔的文本列表，用这行
            dropDownValues(i) = Split(.Formula1, ",")
            ' 如果下拉数据源是单元格区域（比如=Sheet1!A1:A3），替换成下面这行：
            ' dropDownValues(i) = wsOutput.Range(.Formula1).Value
        End With
        comboCounts(i) = UBound(dropDownValues(i)) - LBound(dropDownValues(i)) + 1
    Next i
    
    ' 计算总组合数
    totalCombos = 1
    For i = LBound(comboCounts) To UBound(comboCounts)
        totalCombos = totalCombos * comboCounts(i)
    Next i
    
    ' 初始化组合索引（类似进制数的各位）
    ReDim currentCombo(LBound(dropDownRanges))
    For i = LBound(currentCombo) To UBound(currentCombo)
        currentCombo(i) = LBound(dropDownValues(i))
    Next i
    
    rowNum = 2 ' Summary工作表结果起始行（对应示例中的G2）
    
    ' 遍历所有组合
    Do
        ' 设置当前组合的下拉值
        For i = LBound(dropDownRanges) To UBound(dropDownRanges)
            wsOutput.Range(dropDownRanges(i)).Value = dropDownValues(i)(currentCombo(i))
        Next i
        
        ' 强制刷新计算（针对复杂公式场景）
        Application.Calculate
        
        ' 将C9:C12的结果转置复制到Summary的对应行
        wsOutput.Range("C9:C12").Copy
        wsSummary.Cells(rowNum, "G").PasteSpecial Paste:=xlPasteValues, Transpose:=True
        
        rowNum = rowNum + 1
        
        ' 更新组合索引（模拟进制进位）
        i = UBound(currentCombo)
        Do While i >= LBound(currentCombo)
            currentCombo(i) = currentCombo(i) + 1
            If currentCombo(i) <= UBound(dropDownValues(i)) Then
                Exit Do
            Else
                currentCombo(i) = LBound(dropDownValues(i))
                i = i - 1
            End If
        Loop
        
        ' 所有组合遍历完成则退出循环
        If i < LBound(currentCombo) Then Exit Do
    Loop
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
    
    MsgBox "所有组合已生成完成！"
End Sub

适配调整说明 #

1. 下拉数据源适配：如果数据验证基于单元格区域，替换代码中提取值的对应行
2. 起始位置调整：修改rowNum = 2或wsSummary.Cells(rowNum, "G")来匹配Summary的实际起始行和列
3. 下拉数量调整：如果实际下拉数量不是6个，修改dropDownRanges数组即可

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