VBA迭代下拉列表

我有一个电子表格，J1是一个下拉列表。 第8-14行中的内容将根据您在J1中select的内容进行更改。 我需要遍历下拉列表中的所有值，并将所有相应的行复制到新的工作簿。 复制粘贴部分正在工作，但我有问题迭代通过下拉列表。 特别是，我需要一些帮助来定义Formula1。 我正在使用excel 2010.这是我的代码。 提前致谢

Sub iterate_dropdown() Dim inputRange As Range Dim c As Range Dim Current As Range Set inputRange = Evaluate(Workbooks("sample.xlsm").Worksheets("Credit Research Journal").Range("J1").Validation.Formula1) For Each c In inputRange Workbooks("sample.xlsm").Worksheets("Credit Research Journal").Range("J1").Value = c.Value Workbooks("sample.xlsm").Sheets("Credit Research Journal").Activate Workbooks("sample.xlsm").RefreshAll FinalRow = Cells(Rows.Count, 1).End(xlUp).Row Cells(8, 1).Resize(FinalRow - 7, 10).Copy Workbooks("Book2.xlsm").Sheets("Sheet3").Activate NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 Set Current = Cells(NextRow, 1) Current.PasteSpecial xlPasteValues Next c End Sub 

Answer 1

我对你发布的代码做了一些试验，看起来你很接近。 我发现你得到inputRange的步骤是包含一个等号（=），然后导致评估函数失败。

这是我使用的代码：

  Sub iterate_dropdown() Dim inputRange As Range Dim c As Range Dim Current As Range Dim strRange As String Dim strRange2 As String strRange = Worksheets("Credit Research Journal").Range("J1").Validation.Formula1 strRange2 = Replace(strRange, "=", "") 'Get rid of the equals sign Set inputRange = Evaluate(strRange2) For Each c In inputRange Workbooks("sample.xlsm").Worksheets("Credit Research Journal").Range("J1").Value = c.Value Workbooks("sample.xlsm").Sheets("Credit Research Journal").Activate Workbooks("sample.xlsm").RefreshAll FinalRow = Cells(Rows.Count, 1).End(xlUp).Row Cells(8, 1).Resize(FinalRow - 7, 10).Copy Workbooks("Book2.xlsm").Sheets("Sheet3").Activate NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 Set Current = Cells(NextRow, 1) Current.PasteSpecial xlPasteValues Next c End Sub 

我使用了两个stringvariablesstrRange和strRange2以便您可以轻松地使用debugging器来查看发生了什么。

此外，我假设您的下拉列表正在填入引用其他单元格的值。