我有 4 个数据验证下拉列表，我想使用 for every 循环来迭代 4 个数据验证下拉列表的所有可能值，并将结果复制到工作表中。
下拉菜单位于单元格 H3 和 H4 以及 U3 和 U4 中。 H3 和 U3 包含相同的值，H4 和 U4 包含相同的值。
首先我想检查我的工作表中是否有数据验证列表。
然后我想迭代 4 个下拉值的所有可能值并将结果保存在新的工作表中！
我在 stackoverflow 上找到了一个线程遍历 VBA 下拉列表
从该线程我使用以下代码：
Sub LoopThroughList()
Dim Dropdown1, Dropdown2, Dropdown3, Dropdown4 As String
Dim Range1, Range2, Range3, Range4 As Range
Dim option1, option2, option3, option4 As Range
Dim Counter As Long
Counter = 1
' *** SET DROPDOWN LOCATIONS HERE ***
' ***********************************
Dropdown1 = "H3"
Dropdown2 = "H4"
Dropdown2 = "U3"
Dropdown2 = "U4"
' ***********************************
' ***********************************
Set Range1 = Evaluate(Range("H3").Validation.Formula1)
Set Range2 = Evaluate(Range("H4").Validation.Formula1)
Set Range3 = Evaluate(Range("U3").Validation.Formula1)
Set Range4 = Evaluate(Range("U4").Validation.Formula1)
For Each option1 In Range1
For Each option2 In Range2
For Each option3 In Range3
For Each option4 In Range4
Sheets(2).Cells(Counter, 1) = option1
Sheets(2).Cells(Counter, 2) = option2
Sheets(2).Cells(Counter, 3) = option3
Sheets(2).Cells(Counter, 3) = option4
Counter = Counter + 1
Debug.Print option1, option2, option3, option4
Next option4
Next option3
Next option2
Next option1
End Sub
UPDATE:
我发现了另一个线程https://www.ozgrid.com/forum/forum/help-forums/excel-general/134028-loop-through-excel-drop-down-list-and-copy-paste-the-value?t=190022它使用 VBA 循环遍历两个数据验证下拉列表。
选项显式
Sub LoopThroughDv()
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
Dim i As Long
'Which cell has data validation
Set dvCell = Worksheets("Input Output").Range("I4")
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
i = 0
'Begin our loop
Application.ScreenUpdating = True
For Each c In inputRange
dvCell = c.Value
' Worksheets("Output").Cells(i, "A").Value = dvCell
'Worksheets("Output").Cells(i, "A").Value = Worksheets("Input Output").Range("A1").Value
MsgBox dvCell
Debug.Print dvCell
i = i + 1
Next c
Application.ScreenUpdating = True
End Sub
我该如何改进这段代码？另外，是否可以在循环下保存整个工作表？对于每个循环，我的 vlookups 的值都会发生变化，我想将信息复制到新的工作表中，最后在数据透视表中使用它。
另外，在线程中找到了这段代码循环遍历多个数据验证列表
Sub CopyPaste()
Application.ScreenUpdating = False
Dim inputRange1, inputRange2 As Range
Dim option1, option2 As Range
Set inputRange1 =
Evaluate(Worksheets("Scenario").Range("TabSelection").Validation.Formula1)
Set inputRange2 =
Evaluate(Worksheets("Scenario").Range("IndexSelection").Validation.Formula1)
For Each option1 In inputRange1
Worksheets("Scenario").Range("TabSelection").Value = option1.Value
For Each option2 In inputRange2
ActiveSheet.EnableCalculation = True
Worksheets("Scenario").Range("IndexSelection").Value = option2.Value
Worksheets("Scenario").Range("CopyRange").Copy
With Sheets("Paste").Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Next option2
Next option1
Application.ScreenUpdating = True
End Sub
我尝试将代码最小化为：
Sub LoopThroughDv()
Application.ScreenUpdating = True
Dim inputRange1, inputRange2 As Range
Dim option1, option2 As Range
Set inputRange1 = Evaluate(Worksheets("Input Output").Range("I4").Validation.Formula1)
Set inputRange2 = Evaluate(Worksheets("Input Output").Range("M4").Validation.Formula1)
ActiveSheet.EnableCalculation = True
For Each option1 In inputRange1
ActiveSheet.EnableCalculation = True
Debug.Print option1
Worksheets("Input Output").Range("D10").Value = option1.Value
For Each option2 In inputRange2
Debug.Print option2
Worksheets("Input Output").Range("E10").Value = option2.Value
Next option2
Next option1
Application.ScreenUpdating = True
End Sub
Excel - 过滤表中的数据验证列表这个话题也很有用！
我找到了另一个带有说明的线程确定单元格是否包含数据验证查找数据验证单元格。现在我有了数据验证单元格的地址、公式1 和 incelldropdown。
如何逐步循环进行数据验证？
Option Explicit
Public Sub ShowValidationInfo()
Dim rngCell As Range
Dim lngValidation As Long
For Each rngCell In ActiveSheet.UsedRange
lngValidation = 0
On Error Resume Next
lngValidation = rngCell.SpecialCells(xlCellTypeSameValidation).Count
On Error GoTo 0
If lngValidation <> 0 Then
Debug.Print rngCell.Address
Debug.Print rngCell.Validation.Formula1
Debug.Print rngCell.Validation.InCellDropdown
End If
Next
End Sub
UPDATE:
我发现这段代码可以实现我想要的功能，但它仅适用于一个数据验证下拉列表。如何修改此代码以使用 2 个或 #n 个下拉菜单？
Sub LoopThroughDv()
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
Dim i As Long
'Which cell has data validation
Set dvCell = Worksheets("Input Output").Range("I4")
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
i = 0
'Begin our loop
Application.ScreenUpdating = True
For Each c In inputRange
dvCell = c.Value
' Worksheets("Output").Cells(i, "A").Value = dvCell
'Worksheets("Output").Cells(i, "A").Value = Worksheets("Input Output").Range("A1").Value
MsgBox dvCell
Debug.Print dvCell
i = i + 1
Next c
Application.ScreenUpdating = True
End Sub
2018 年 7 月 24 日更新：
我仍在尝试循环遍历我的 4 个数据验证列表，有人可以帮助我调整下面的代码以使用 2 个数据验证列表吗？
Option Explicit
Sub LoopThroughValidationList()
Dim lst As Variant
Dim rCl As Range
Dim str As String
Dim iX As Integer
str = Range("B1").Validation.Formula1
On Error GoTo exit_proc:
If Left(str, 1) = "=" Then
str = Right(str, Len(str) - 1)
For Each rCl In Worksheets(Range(str).Parent.Name).Range(str).Cells
Range("B1").Value = rCl.Value
Next rCl
Else
lst = Split(str, ",")
For iX = 0 To UBound(lst)
Range("B1").Value = lst(iX)
Next iX
End If
Exit Sub
exit_proc:
MsgBox "No validation list ", vbCritical, "Error"
End Sub
