列中的依赖下拉列表

Question

我需要什么
两列，每一行都有一个下拉列表，我可以在其中选择代码，另一列每行都有一个下拉列表，将根据该列表选择显示子代码。

我有什么
用 VBA 代码填充所有 J 列的代码：

Sub main()
Dim lCopyLastRow As Long
lCopyLastRow = Workbooks("Reports.xlsm").Worksheets("Data").Cells(Workbooks("Reports.xlsm").Worksheets("Data").Rows.Count, "AT").End(xlUp).Row

'replace "J2" with the cell you want to insert the drop down list
With Range("J2").Validation
    .Delete
    'replace "=A1:A6" with the range the data is in.
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
      Operator:=xlBetween, Formula1:="=Data!$AT$2:$AT$" & lCopyLastRow
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub

当我尝试对相关下拉列表执行相同操作时，我收到错误。

Sub main2()
Dim lCopyLastRow As Long

'replace "J2" with the cell you want to insert the drop down list
With Range("K2").Validation
    .Delete
    'replace "=A1:A6" with the range the data is in.
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
      Operator:=xlBetween, Formula1:="=OFFSET(Data!$E$1,MATCH($J2,Data!$C$2:$C$6253,0),0,COUNTIF(Data!$C$2:$C$6253,$J2))"
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub

我知道问题出在公式上。

Excel File

Answer 1

只要解释得当，这个任务就很简单了。

概念如下：
J-cell 是“J”列中的更改单元格，K-cell 是“K”列中的单元格与 J-cell 在同一行。
1.设置工作簿打开时对“J”列的数据验证；
2. 捕捉任何单个J-cells的每一个变化；
3.根据J-cell的值生成验证列表；
4. 检查此类列表是否已创建并具有值；
5. 将数据验证设置为 K 细胞。

解决方案：
确保概念 #1 - 为 Workbook_Open 事件创建处理程序

代码如下：

Private Sub Workbook_Open()

' Set data validation to column "J" (concept #1)
SetValidationToJ
End Sub

为Worksheet_Change 事件创建处理程序，确保选择正确的工作表和事件。

此事件处理程序的代码（参见 cmets）：

Private Sub Worksheet_Change(ByVal Target As Range)
' Target - is the changed cell or range of cells
Dim dataArray()

With Target.Parent
    ' the check to catch a change of single cell only
    If Not Target.Rows.Count > 1 And Target.Columns.Count > 1 Then
        ' check that this cell in column "J" (concept #2)
        If Not Intersect(Target, .Columns(10)) Is Nothing Then
            ' if cell was just cleared
            If Target.Value = "" Then
                ' then remove validation from appropriate cell in column "K"
                .Cells(Target.Row, 11).Validation.Delete
            Else
                ' otherwise try to generate validation list (concept #3)
                dataArray = GetValuesForKValidation(Target)

                ' if validation list has some values (concept #4)
                If Not Not dataArray Then
                    ' set validation to appropriate cell in column "K" (concept #5)
                    SetValidationToK dataArray, Target.Row
                Else
                    'if no values - remove old validation as inappropriate
                    .Cells(Target.Row, 11).Validation.Delete
                    '[... your handler for other stuff...]
                End If
            End If
        End If
    End If
End With

End Sub

剩下的代码（2个subs和1个函数）将被放置到常规模块中：

Option Explicit
Dim dataSht As Worksheet

Sub SetValidationToJ()
Dim lastRow As Long
Dim sourceRngJ As Range

If dataSht Is Nothing Then Set dataSht = ThisWorkbook.Sheets("Data")

With dataSht
    Set sourceRngJ = Range(.Cells(2, 46), .Cells(Rows.Count, 46).End(xlUp))
    lastRow = .Cells(Rows.Count, 46).End(xlUp).Row

    With Range(.Cells(2, 10), .Cells(lastRow, 10)).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=" & sourceRngJ.Address
        .IgnoreBlank = True
        .InCellDropdown = True
        .ErrorTitle = "Error!"
        .ErrorMessage = "You must select from provided list!"
        .ShowError = True
    End With
End With

End Sub

Sub SetValidationToK(Values() As Variant, RowNum As Long)

If dataSht Is Nothing Then Set dataSht = ThisWorkbook.Sheets("Data")

With dataSht
    With .Cells(RowNum, 11).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:=Join(Values, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ErrorTitle = "Error!"
        .ErrorMessage = "You must select from provided list!"
        .ShowError = True
    End With
End With

End Sub

Function GetValuesForKValidation(SrcRange As Range) As Variant
Dim r As Range, searchRange As Range
Dim output() As Variant
Dim i As Integer

If dataSht Is Nothing Then Set dataSht = ThisWorkbook.Sheets("Data")

With dataSht
    Set searchRange = Range(.Cells(2, 3), .Cells(Rows.Count, 3).End(xlUp))
End With

For Each r In searchRange
    If r.Value = SrcRange.Value Then
        ReDim Preserve output(i)
            output(i) = r.Offset(0, 2).Value
            i = i + 1
    End If
Next

GetValuesForKValidation = output

End Function

欢迎评论。

Answer 2

我在用户窗体上创建了一个带有相关下拉列表的示例。我希望它对您有用。 该数据库包括产品、产品类别、产品供应商和价格。即使表中的数据混杂在一起，我们也可以通过在链接的下拉列表中按类别和供应商对产品进行分组来轻松地检查产品，数据可以输入到其他表中。

我在工作表上定义了名称并使用了 Dictionary 对象：

Private Sub UserForm_Initialize()
Dim k As Byte, x As Variant
Me.BackColor = 15658720
For k = 1 To 4
Controls("Frame" & k).BackColor = 15658720
Next
 Supplier = Application.Transpose(Range("Supplier"))
 Category = Application.Transpose(Range("Category"))
 Product = Application.Transpose(Range("Product"))
 Price = Application.Transpose(Range("Price"))
 Set ScDctnry = CreateObject("Scripting.Dictionary")
  For Each x In Supplier
      SD(x) = ""
 Next x
  ComboBox1.List = ScDctnry.keys
 End Sub

Source and sample files here