Excel VBA Для каждого цикла со списками проверки данных

Question

У меня есть 4 раскрывающихся списка проверки данных, и я хочу использовать для каждого цикла, чтобы перебрать все возможные значения 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 и выпадающий список ячеек проверки данных.

Как можно пошагово пройти проверку данных?

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 07 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

Answer 1

Этот код будет работать, даже если именованные диапазоны, использующие INDEX и MATCH, недопустимы.

ExtractDataValidationList: Sub

Sub ExtractDataValidationList(Source As Range, Optional TargetWorkSheet As Worksheet)
    Dim cell As Range, rValidation As Range
    Dim list As Object, item As Variant, values As Variant
    On Error Resume Next
    Set rValidation = Source.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0

    If rValidation Is Nothing Then
        MsgBox "No Data Validation Found"
    Else
        Set list = CreateObject("System.Collections.ArrayList")
        For Each cell In rValidation
            On Error Resume Next
            values = Range(cell.Validation.Formula1).Value
            If Err.Number <> 0 Then values = Split(cell.Validation.Formula1, ",")
            On Error GoTo 0

            For Each item In values
                If Not list.Contains(item) Then list.Add item
            Next
        Next

        If list.Count = 0 Then
            MsgBox "No Items in Data Validation Formula1"
        Else
            list.Sort
            If TargetWorkSheet Is Nothing Then Set TargetWorkSheet = Worksheets.Add
            TargetWorkSheet.Range("A1").Resize(list.Count).Value = WorksheetFunction.Transpose(list.ToArray)
        End If
    End If

End Sub

Использование

 ExtractDataValidationList ActiveSheet.Cells