Excel VBA迭代下拉列表

我有一个表格，其中J1是一个下拉列表。第8-14行中的内容将根据您在J1中选择的内容进行更改。我需要遍历下拉列表中的所有值，并将所有对应的行复制到新工作簿中。复制粘贴部分正在工作，但我在遍历下拉列表时遇到问题。特别是，我需要一些帮助来定义公式1。我正在使用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

---

我对你发布的代码做了一些实验，看起来你已经非常接近了。我发现您获取

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

我使用了两个字符串变量

strRange

和

strRange2

，这样您就可以轻松地使用调试器查看发生了什么

---

另外，我假设您的下拉列表中填充了引用其他单元格的值。

我对您发布的代码进行了一些实验，您似乎非常接近。我发现您获取

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

我使用了两个字符串变量

strRange

和

strRange2

，这样您就可以轻松地使用调试器查看发生了什么

---

另外，我假设您的下拉列表中填充了引用其他单元格的值。

正确缩进代码。编辑您的帖子并选择所有代码段，然后执行

ctrl-k

。或者是mac的

cmd-k

。它看起来更好吗？正确缩进代码。编辑您的帖子并选择所有代码段，然后执行

ctrl-k

。或者是mac的cmd-k。它看起来更好吗？它工作得很好。非常感谢你。你能给我解释一下.Validation.Formula1的作用吗？这是一个内置函数还是一个变量？如果是一个变量，它指的是什么？如果是一个函数，它调用什么？实际上，在仔细查看结果之后，代码并没有真正遍历列表并提取相应的行。相反，它会在列表中找到一个值，并多次复制相同的行。你能给我一些建议吗？你想复制的范围是多少？它工作得很好。非常感谢你。你能给我解释一下.Validation.Formula1的作用吗？这是一个内置函数还是一个变量？如果是一个变量，它指的是什么？如果是一个函数，它调用什么？实际上，在仔细查看结果之后，代码并没有真正遍历列表并提取相应的行。相反，它会在列表中找到一个值，并多次复制相同的行。你能给我一些建议吗？你想复制的范围是多少？