使用In-cell下拉列表中的值自动填充单元格 - VBA

Posted 2021-05-05

目标

我想循环三张（我从一张开始），在C列中查找某个类型并自动填充/自动填充D列中的In-cell下拉列表（类似于数据验证设置中的类型） 。In-cell下拉列表应列出所有类型的值，但应该使用属于Type的值自动填充。

问题

下面的代码使用相同的值填充每个In-cell下拉列表，即Type1的Item1 - Item2 - Item3 - Item4。

我不知道如何列出所有值，同时自动填充单元格。

期望的输出

码

为简单起见，我在下面的代码中只添加了两个第一类。

Sub AutoDropdown()

Dim PersonSource As Range
Dim PersonSourceTotal As Range
Dim PersonCell As Range
'Dim ws As Worksheet

Dim i As Integer
Dim lastRow As Integer

Set PersonSourceTotal = Sheets("Sheet1").Range("D2:D200")

With PersonSourceTotal.Offset(0, -2)
    lastRow = .Cells(.Rows.Count, PersonSourceTotal.Columns.Count).End(xlUp).Row
End With

Set PersonSource = Sheets("sheet1").Range("D2:D" & lastRow)

On Error Resume Next

For Each PersonCell In PersonSource
    Name = PersonCell.Offset(0, -3)
    ID = PersonCell.Offset(0, -2)
        If Name <> "" And ID <> "" Then
            For i = 0 To lastRow
                If PersonCell.Offset(i, -1) = "Type1" Then
                    arr1 = Array("Item1", "Item2", "Item3", "Item4")
                    arr1Merged = Join(arr1, "--")
                    With PersonCell.Validation
                                                .Delete
                                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                                                Operator:=xlBetween, Formula1:=arr1Merged
                                                .IgnoreBlank = True
                                                .InCellDropdown = True
                                                .InputTitle = ""
                                                .ErrorTitle = ""
                                                .InputMessage = ""
                                                .ErrorMessage = ""
                                                .ShowInput = True
                                                .ShowError = True
                    End With
                ElseIf PersonCell.Offset(i, -1) = "Type2" Then
                    arr2 = Array("Item5", "Item6", "Item7", "Item8", "Item9")
                    arr2Merged = Join(arr2, "--")
                    Debug.Print (arr2Merged)
                    With PersonCell.Validation
                                                .Delete
                                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                                                Operator:=xlBetween, Formula1:=arr2Merged
                                                .IgnoreBlank = True
                                                .InCellDropdown = True
                                                .InputTitle = ""
                                                .ErrorTitle = ""
                                                .InputMessage = ""
                                                .ErrorMessage = ""
                                                .ShowInput = True
                                                .ShowError = True
                    End With
                End If
            Next i
        Else
            MsgBox "Remember to add Name and ID"
        End If
Next PersonCell
End Sub

答案

编辑：

在您发表评论后，我已更新代码以尝试更好地反映您的要求：

Sub AutoDropdown()
Dim PersonSource As Range
Dim PersonSourceTotal As Range
Dim PersonCell As Range
Dim i As Long
Dim lastRow As Long
Dim SelectionArray(1 To 4) As String

Set PersonSourceTotal = Sheets("Sheet1").Range("D2:D200")

With PersonSourceTotal.Offset(0, -2)
    lastRow = .Cells(.Rows.Count, PersonSourceTotal.Columns.Count).End(xlUp).Row
End With

Set PersonSource = Sheets("Sheet1").Range("D2:D" & lastRow)

arr1 = Array("Item1", "Item2", "Item3", "Item4") 'Define your selections items
arr2 = Array("Item5", "Item6", "Item7", "Item8", "Item9")
arr3 = Array("ItemE", "ItemF", "ItemG", "ItemH")
arr4 = Array("ItemA", "ItemB", "ItemC", "ItemD")

SelectionArray(1) = Join(arr1, "--") 'join the selections into another array
SelectionArray(2) = Join(arr2, "--")
SelectionArray(3) = Join(arr3, "--")
SelectionArray(4) = Join(arr4, "--")
AllSelections = Join(SelectionArray, ",") 'group all selections for data validation
On Error Resume Next

For Each PersonCell In PersonSource
    VarName = PersonCell.Offset(0, -3)
    ID = PersonCell.Offset(0, -2)
        If VarName <> "" And ID <> "" Then
            Select Case PersonCell.Offset(i, -1).Value
                Case "Type1"
                    With PersonCell.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections
                    End With
                    PersonCell.Value = SelectionArray(1)
                Case "Type2"
                    With PersonCell.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections
                    End With
                    PersonCell.Value = SelectionArray(2)
                Case "Type3"
                    With PersonCell.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections
                    End With
                    PersonCell.Value = SelectionArray(3)
                Case "Type4"
                With PersonCell.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=AllSelections
                    End With
                    PersonCell.Value = SelectionArray(4)
                Case Else
                    MsgBox "No Type was entered on Column C"
            End Select
        Else
            MsgBox "Remember to add VarName and ID"
        End If
Next PersonCell
End Sub

更新：

要使上面的代码在更改C列的值（即类型编号）时自动运行，则应在Sheet1下添加以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then AutoDropdown 'if a value is changed on Column 3/ Column C then call the name of the above subroutine, in this case it is called AutoDropdown
End Sub