Как заставить зависимые поля со списком функционировать в VBA

Question

У меня есть следующая таблица:

Мне нужно получить два зависимых поля со списком.

• 1-я комбинация - у меня должны быть опции игрушка 1 и игрушка 2
• 2-я комбинация на основе выбора 1 не должен отображаться список колес
• 3-я комбинация на основе выбора комбинации 1 Название должнобыть показано

Я попробовал следующий код.Когда форма инициализирована, я получаю список combo1 И когда выбрано combo 1, я загружаю combo 2 и 3

Private Sub UserForm_Initialize()
Dim i As Long
   For i = 2 To 9
     Me.ComboBox1.AddItem Cells(i, 1)
   Next
End Sub

Private Sub ComboBox1_Change()
    Me.ComboBox2.Value = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, Sheets("sheet1").Range("A2:C9"), 2, 0)
    Me.ComboBox3.Value = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, Sheets("sheet1").Range("A2:C9"), 3, 0)
End Sub

Проблема в том, что когда я запускаю, combo1 не только 2 выбора toy1 и toy2, но этоповторите toy1 4 раза и toy2 4 раза.

Когда я выбираю комбо 2 и 3, показывается только одно значение, а не весь идентификатор списка.

Пожалуйста, помогите мне разобраться с этим.Спасибо

Answer 1

Очень интересно, что я работал над проектом, у которого были похожие требования.Я не мог закончить это полный проект.Вот код для удовлетворения ваших требований.Здесь, когда вы выберете любое значение cboToyType и перейдете к cboWheel, выполнение кода займет совсем немного времени.Вы можете оптимизировать коды, чтобы ускорить его.

Private Sub UserForm_Initialize()
Dim ws As Worksheet

    Set ws = Sheets("Sheet1")
    ws.Range("Z:Z").ClearContents
    ws.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z1"), Unique:=True
    ws.Range("Z1").ClearContents

    Me.cboToyType.RowSource = ws.Range("Z2").CurrentRegion.Address
    Set ws = Nothing
End Sub


Private Sub btnOK_Click()
    Unload Me
End Sub


Private Sub cboToyType_AfterUpdate()
Dim ws As Worksheet
Application.ScreenUpdating = False

    Set ws = Sheets("Sheet1")
    ws.Range("AB:AD").ClearContents
    ws.Range("A:C").AutoFilter Field:=1, Criteria1:=Me.cboToyType
    ws.Range("B:B").Copy ws.Range("AB1")
    ws.Range("AB:AB").RemoveDuplicates Columns:=1, Header:=xlNo

    ws.Range("C:C").Copy ws.Range("AD1")
    ws.Range("AD:AD").RemoveDuplicates Columns:=1, Header:=xlNo

    ws.Range("A:C").AutoFilter
    ws.Range("AB1").ClearContents
    ws.Range("AD1").ClearContents

    Me.cboWheel.RowSource = ws.Range("AB2").CurrentRegion.Address
    Me.cboName.RowSource = ws.Range("AD2").CurrentRegion.Address
    Set ws = Nothing

Application.ScreenUpdating = True
End Sub

Образец ссылки для загрузки файла