Question

我有这个问题，我不知道如何解决它。所以：

我有3列不同的数据：ex（）：

ColA ColB ColC

FPROC C5 V-250396

FPROC C4 V-250396

FPROC C4 V-250397

FPROC C4 V-250398

FPROC C4 V-250399

FPROC H1 V-250400

FPROC H2 V-250401

FPROC H3 V-250402

JISBL C5 V-250403

JISBL C4 V-250404

JISBL H1 V-250405

JISBL H2 V-250406

JISBL C4 V-250405

JISBL H2 V-250407

单元格D1上的

我将根据ColA值

获得验证列表

在单元格E1上我将有一个基于ColB值过滤的验证列表，其中colA值为

单元格F1上的

我将有一个基于ColC值的验证列表，其中包含colA值和ColB值。

示例：

我选择了D1：FPROC＆gt;＆gt;在单元格E1上，我将有一个DV（数据验证列表）：C5，C4，H1，H2，H3

我选择了E1：C4＆gt;＆gt;在F1上我想要一台DV：V-250396，V-250397，V-250398，V-250399

因此，基于从D1 + E1的选择，在F1中具有正确的DV值。

我有以下代码，它适用于第一个（D1）和第二个（E1）DV但是对于最后一个（F1），它运行不正常。

有任何关于找到正确值的建议吗？（谢谢！）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, LastRow As Long, n As Long
    Dim MyCol As Collection
    Dim SearchString As String, TempList As String

    Application.EnableEvents = False

    On Error GoTo WTF

    'LastRow in Col A
    LastRow = Range("A" & Rows.Count).End(xlUp).Row

    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Set MyCol = New Collection

        'data from Col A into a collection
        For i = 1 To LastRow
            If Len(Trim(Range("A" & i).Value)) <> 0 Then
                On Error Resume Next
                MyCol.Add CStr(Range("A" & i).Value), CStr(Range("A" & i).Value)
                On Error GoTo 0
            End If
        Next i

        'list for the DV List
        For n = 1 To MyCol.Count
            TempList = TempList & "," & MyCol(n)
        Next

        TempList = Mid(TempList, 2)

        Range("D1").ClearContents: Range("D1").Validation.Delete
        Range("E1").ClearContents: Range("E1").Validation.Delete

        ' Create the DV List
        If Len(Trim(TempList)) <> 0 Then
            With Range("D1").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    '~~> Capturing change in cell D1
    ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then

        SearchString = Range("D1").Value


        TempList = FindRange(Range("A1:A" & LastRow), SearchString)
        TempList = RemoveDuplicates(TempList)

        Range("E1").ClearContents: Range("E1").Validation.Delete

        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("E1").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    '~~> Capturing change in cell E1
    ElseIf Not Intersect(Target, Range("E1")) Is Nothing Then
        SearchString = Range("E1").Value

        TempList = FindRange(Range("B1:B" & LastRow), SearchString)
        TempList = RemoveDuplicates(TempList)

        Range("F1").ClearContents: Range("F1").Validation.Delete

        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("F1").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If

    End If


LetsContinue:
    Application.EnableEvents = True
    Exit Sub
WTF:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Function FindRange(FirstRange As Range, StrSearch As String) As String
    Dim aCell As Range, bCell As Range, oRange As Range
    Dim ExitLoop As Boolean
    Dim strTemp As String

    Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    ExitLoop = False

    If Not aCell Is Nothing Then
        Set bCell = aCell
        strTemp = strTemp & "," & aCell.Offset(, 1).Value
        Do While ExitLoop = False
            Set aCell = FirstRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                'strTemp = strTemp & Application.International(xlListSeparator) & aCell.Offset(, 1).Value
                strTemp = strTemp & "," & aCell.Offset(, 1).Value
            Else
                ExitLoop = True
            End If
        Loop
        FindRange = Mid(strTemp, 2)
    End If
End Function

Function RemoveDuplicates(str As String) As String

Dim aryInitial As Variant
Dim strFinal As String
Dim i As Long

aryInitial = Split(str, ",")

For i = LBound(aryInitial) To UBound(aryInitial)
    If InStr(strFinal, Trim(aryInitial(i))) = 0 Then
        strFinal = strFinal & aryInitial(i) & ","
    End If
Next i

RemoveDuplicates = strFinal

End Function

Answer 1

您正在做的是将依赖验证列表设置为三个级别。前两个相对简单。第三个是复杂的，因为您必须为A列和B列中项目的所有有效组合创建一个列表。

这就是下面的例程;并且，为了防止自己变得过于混乱:-)，我设置了一个类对象来创建＆＃34;键＆＃34;为高等教育名单。我创建的NAME＆＃f; d范围的键和标题是通过连接前两个条目的以管道分隔的字符串组成的。我相信，这个代码更容易理解。

我在一个标题为＆＃34; Lists＆＃34;的单独工作表上将验证列表设置为命名范围，然后使用Excel的间接功能来决定显示哪个列表（关于二级和三级）水平）。

希望你能比较清楚。

应该重命名类模块＆＃34; CLists＆＃34;

以下代码进入课程模块：

=======================================

Option Explicit
Private pPrimaryKey As String
Private pSecondaryKey As String

Public Property Get PrimaryKey() As String
    PrimaryKey = pPrimaryKey
End Property
Public Property Let PrimaryKey(Value As String)
    pPrimaryKey = Value
End Property

Public Property Get SecondaryKey() As String
    SecondaryKey = pSecondaryKey
End Property
Public Property Let SecondaryKey(Value As String)
    pSecondaryKey = Value
End Property

=====================================

然后这段代码进入常规模块：

===========================================

Option Explicit
Sub CreateDV()
    Dim R1 As Range, R2 As Range, R3 As Range
    Dim wsLists As Worksheet, wsMain As Worksheet
    Dim V As Variant
    Dim CL As CLists
    Dim colPrimary As Collection, colSecondary As Collection, colTertiary As Collection
    Dim colTertiaryKeys As Collection
    Dim vPrimary(), vSecondary(), vTertiary()
    Dim I As Long, J As Long, K As Long

Set wsMain = Worksheets("Sheet1")
Set wsLists = Worksheets("Lists")

With wsMain
    V = .Range("a1", .Cells(Rows.Count, "a").End(xlUp)).Resize(COLUMNSIZE:=3)
End With

'Create the lists
'Create the main list
Set colPrimary = New Collection
On Error Resume Next
For I = 1 To UBound(V, 1)
    colPrimary.Add Item:=V(I, 1), Key:=CStr(V(I, 1))
Next I
ReDim vPrimary(0 To colPrimary.Count, 1 To 1)
vPrimary(0, 1) = "Primary"
For I = 1 To colPrimary.Count
    vPrimary(I, 1) = colPrimary(I)
Next I

'create secondary sublists
ReDim vSecondary(0 To UBound(V, 1), 1 To UBound(vPrimary, 1))
For I = 1 To UBound(vPrimary, 1)
    Set colSecondary = New Collection
    For J = 1 To UBound(V)
        If V(J, 1) = vPrimary(I, 1) Then _
            colSecondary.Add V(J, 2), CStr(vPrimary(I, 1) & V(J, 2))
    Next J
    vSecondary(0, I) = vPrimary(I, 1)
    For K = 1 To colSecondary.Count
        vSecondary(K, I) = colSecondary(K)
    Next K
Next I

'create tertiary sublists
'will need one list for each possible combination of the first two
'Generate List of Tertiary lists
Set colTertiaryKeys = New Collection
For I = 1 To UBound(vSecondary, 2)
    For J = 1 To UBound(vSecondary, 1)
        Set CL = New CLists
            If vSecondary(J, I) <> "" Then
        With CL
            .PrimaryKey = vSecondary(0, I)
            .SecondaryKey = vSecondary(J, I)
            colTertiaryKeys.Add CL
        End With
            End If
    Next J
Next I

ReDim vTertiary(0 To UBound(V, 1), 1 To colTertiaryKeys.Count)
For I = 1 To colTertiaryKeys.Count
    Set colTertiary = New Collection
    With colTertiaryKeys(I)
    For J = 1 To UBound(V, 1)
        If V(J, 1) = .PrimaryKey And _
            V(J, 2) = .SecondaryKey Then _
            colTertiary.Add V(J, 3), CStr(.PrimaryKey & "_" & .SecondaryKey & V(J, 3))
    Next J
    vTertiary(0, I) = .PrimaryKey & "_" & .SecondaryKey
    For K = 1 To colTertiary.Count
        vTertiary(K, I) = colTertiary(K)
    Next K
    End With
Next I

On Error GoTo 0

'Write the DV lists someplace and NAME them
'Primary list
With Worksheets("Lists")
    Set R1 = .Cells(1, 1).Resize(UBound(vPrimary, 1) + 1)
    Set R2 = .Cells(1, R1.Columns.Count + 2).Resize(UBound(vSecondary, 1) + 1, UBound(vSecondary, 2))
    Set R3 = .Cells(1, R2.Column + R2.Columns.Count + 2).Resize(UBound(vTertiary, 1) + 1, UBound(vTertiary, 2))
    .Cells.Clear
End With

R1 = vPrimary
R2 = vSecondary
R3 = vTertiary

'Create Named Lists
Application.DisplayAlerts = False
R1.CreateNames True, False, False, False
With R2
    For I = 1 To .Columns.Count
        Range(.Cells(1, I), .Cells(.Rows.Count, I).End(xlUp)).CreateNames True, False, False, False
    Next I
End With
With R3
    For I = 1 To .Columns.Count
        Range(.Cells(1, I), .Cells(.Rows.Count, I).End(xlUp)).CreateNames True, False, False, False
    Next I
End With
Application.DisplayAlerts = True

'Add the DV schemes
Application.ScreenUpdating = False
With wsMain
    With .Range("D1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=primary"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    'need something there or next cell errors out
    'with screenupdating off, this won't be seen, as we will delete it when done
    .Range("d1").Value = Range("primary")(1)

    With .Range("E1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=indirect(d1)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    .Range("e1").Value = Range(Range("d1").Text)(1)

    With .Range("F1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=indirect(d1 & ""_"" & e1)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    .Range("D1:F1").ClearContents
End With
Application.ScreenUpdating = True

End Sub

=======================================

玩了一段时间之后，我发现，只要在D1：F1中进行了更改，就应该清除从属列表中的条目，否则它们将会“不同步”＃34 ;。因此，应在工作表模块代码中输入以下代码以捕获该更改并清空依赖单元格，具体取决于更改的内容。

=================================

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rDV As Range
Set rDV = Range("D1:E1")
If Not Intersect(rDV, Target) Is Nothing Then
    Target(1, 2).ClearContents
End If

End Sub

===================================

Answer 2

非常感谢您花时间和经验。目前代码接缝存在一些问题（在我的情况下）。例如：在col A中添加一个新值（给出错误1004），然后在D1和E1上不能选择不同的值（只有第一个）。我明天会尝试消化你的代码（现在，这里已经晚了，比利时）。无论如何，你的代码对我的VBA体验来说有点太多了（也许一个好的睡眠会帮助我）。再次感谢！

Answer 3

感谢您的解决方案（excel表）。我尝试了一种不同的方法（从我的观点来看更容易）。我把它作为答案，因为代码与你的不同。我没有解释（代码），因为你的经验知道要阅读里面的东西。请告诉我你的观点（谢谢！）。

这是文件：excel file

这是代码：

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, n As Long
    Dim MyCol As Collection
    Dim SearchString As String, TempList As String
    Dim LastRow As Long
    Dim j As Integer

    Application.EnableEvents = False

    On Error GoTo WTF

    'LastRow in Col A
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    ReDim matrice(LastRow, 2) As String

        Set MyCol = New Collection

        'data from Col A into a collection
        For i = 1 To LastRow
            If Len(Trim(Range("A" & i).Value)) <> 0 Then
                On Error Resume Next
                MyCol.Add CStr(Range("A" & i).Value), CStr(Range("A" & i).Value)
                matrice(i - 1, 0) = CStr(Range("A" & i).Value)
                matrice(i - 1, 1) = Range("A" & i).Offset(, 1).Value
                matrice(i - 1, 2) = Range("A" & i).Offset(, 2).Value
                On Error GoTo 0
            End If
        Next i

    If Not Intersect(Target, Columns(1)) Is Nothing Then
        'list for the DV List
        For n = 1 To MyCol.Count
            TempList = TempList & "," & MyCol(n)
        Next


        TempList = Mid(TempList, 2)

        Range("D1").ClearContents: Range("D1").Validation.Delete
        Range("E1").ClearContents: Range("E1").Validation.Delete
        Range("F1").ClearContents: Range("F1").Validation.Delete

        ' Create the DV List
        If Len(Trim(TempList)) <> 0 Then
            With Range("D1").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    '~~> Capturing change in cell D1
    ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then

        For j = LBound(matrice) To UBound(matrice) - 1
           If matrice(j, 0) = Range("D1").Value Then
               TempList = TempList & "," & matrice(j, 1)
           End If
        Next j

        TempList = RemoveDuplicates(TempList)

        Range("E1").ClearContents: Range("E1").Validation.Delete
        Range("F1").ClearContents: Range("F1").Validation.Delete

        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("E1").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    '~~> Capturing change in cell E1
    ElseIf Not Intersect(Target, Range("E1")) Is Nothing Then

        For j = LBound(matrice) To UBound(matrice) - 1
           If matrice(j, 0) = Range("D1").Value And matrice(j, 1) = Range("E1").Value Then
               TempList = TempList & "," & matrice(j, 2)
           End If
        Next j

        TempList = RemoveDuplicates(TempList)

        Range("F1").ClearContents: Range("F1").Validation.Delete

        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("F1").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If

    End If
LetsContinue:
    Application.EnableEvents = True
    Exit Sub
WTF:
    MsgBox Err.Description
    Resume LetsContinue
End Sub
Function RemoveDuplicates(str As String) As String

Dim aryInitial As Variant
Dim strFinal As String
Dim i As Long

aryInitial = Split(str, ",")

For i = LBound(aryInitial) To UBound(aryInitial)
    If InStr(strFinal, Trim(aryInitial(i))) = 0 Then
        strFinal = strFinal & aryInitial(i) & ","
    End If
Next i

RemoveDuplicates = strFinal

End Function

使用VBA过滤2列的数据验证列表

3 个答案: