VBA代码遍历下拉列表，然后将每次迭代的范围复制/粘贴到新选项卡中

Question

我有一个工作表（“分析”），其中有一个包含5个选项的下拉验证列表。下拉列表位于单元格B6中。我想遍历此下拉列表中的5个选项，这些选项会产生包含在B10：N25范围内的不同摘要结果，然后将值复制到新的工作表中（“输出”）。我想要“输出”表中这5个迭代中的每一个的摘要结果，因此需要使用每个循环更新输出表中目标单元格的代码，以使其不会粘贴在同一区域上。谢谢！

我尝试了几个VBA选项，但这些选项是为单行数据或为每次迭代创建新标签而编写的。

Sub Iteration_Loop()
'
' Iteration_Loop Macro
' Loops through alternatives
'

' create variables
    Dim input As Range
    Dim c As Range

    Set input = Evaluate(Sheets("Analysis").Range("B6").Validation.Formula1)
    For Each c In input
    Calculate
    Sheets("Analysis").Range("B10:N25").Copy
    Sheets("Output Sheet").Range("C5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=
    '    xlNone , SkipBlanks:=False, Transpose:=False

    Next c

End Sub

我认为这可以进行迭代，但是只是在Output中相同范围内进行复制。

Answer 1

尽管无法清楚地理解问题，但假设目标单元随迭代而改变（否则，它必然与先前粘贴的区域重叠）。我用它像下面的20行块一样一个一个地复制了下来

。 Input是VBA中的关键字，不能用作变量。

Sub Iteration_Loop()
Dim Rng As Range
Dim c As Range
Dim DestRow As Long

     'Set Rng to the list of values in the validation list
Set Rng = Sheets("Analysis").Range(Sheets("Analysis").Range("B6").Validation.Formula1)
DestRow = 0

     For Each c In Rng.Cells
     Sheets("Analysis").Range("B6").Value = c.Value
     Application.Calculate
     Sheets("Analysis").Range("B10:N25").Copy
     Sheets("Output Sheet").Range("C" & DestRow + 5).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
     DestRow = DestRow + 20
     Next c

End Sub

Answer 2

这是我的解决方案，其中包括代码中的注释：

Sub t()

    'Input will give you an error
    Set Input_Analysis = Evaluate(Sheets("Analysis").Range("B6").Validation.Formula1)
    For Each Value In Input_Analysis
        'Calculate -> you can use Application.Calculation = xlCalculationAutomatic, you should set it to xlManual first if you want to stop it, default - auto
        Application.Calculation = xlCalculationAutomatic
        '+ 2 since you want to paste it at least (1) row beneath the last one
        Last_Filled_Row = ThisWorkbook.Sheets("Output Sheet").Range("C104764").End(xlUp).Row + 2
        'assuming you at least want to start pasting as of row 15
        If Last_Filled_Row < 15 Then
            Last_Filled_Row = 15
        End If

        ThisWorkbook.Sheets("Analysis").Range("B10:N25").Copy
        'use the row as retrieved above
        ThisWorkbook.Sheets("Output Sheet").Range("C" & Last_Filled_Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Next Value

End Sub