具有多個列表的可變數據驗證

Question

您好Stackoverflow社區，

下面是Excel中“表格1”的A列和B列中的網站列表和客戶列表。

Site    Customer
Paddington  A
Sydney      B
Vaucluse    A
Maroubra    A
Woollahra   B
Sydney      A
Sydney      A

我遇到的問題如下：

我的網站數據驗證列表是唯一的（無重復）。 但是，我也需要我的客戶在本質上也要獨特。 問題示例：“悉尼”在站點列表中是唯一的，但是當選擇“悉尼”時，客戶在客戶列表中是B，A，A。

以下是我的VBA代碼：

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 Whoa

'~~> Find 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

    '~~> Get the data from Col A into a collection
    For i = 2 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

    '~~> Create a 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

    '~~> 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("A2:A" & LastRow), SearchString)

    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
End If

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

'~~> Function required to find the list from Col B
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 & "," & aCell.Offset(, 1).Value
        Else
            ExitLoop = True
        End If
    Loop
    FindRange = Mid(strTemp, 2)
End If
End Function

任何幫助將不勝感激

提前致謝

Answer 1

如果您不關心丟失重復的行，那么如果添加以下行，則程序將獲得兩個行的所有唯一值：

Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

在頂部-在出現On Error和LastRow計算之前

On Error GoTo Whoa

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

Answer 2

通過跳過代碼的某些部分，它應按您希望的方式執行：

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim vals As Variant, MyCol As New Collection, runner As Variant, str As String, i As Long

  If Not Intersect(Target, Columns(1)) Is Nothing Then

    vals = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value2
    Range("D1").ClearContents

    On Error Resume Next
    For Each runner In vals
      If Len(Trim(runner)) Then
        MyCol.Add Trim(runner), Trim(runner)
      End If
    Next
    On Error GoTo 0

    If MyCol.Count Then
      For Each runner In MyCol
        str = str & "," & runner
      Next

      With Range("D1").Validation
        .Delete
        .Add 3, 1, 1, Mid(str, 2)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
      End With
    End If

  ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then

    vals = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value2
    runner = Range("D1").Value2
    Range("E1").ClearContents

    On Error Resume Next
    For i = 1 To UBound(vals)
      If Trim(vals(i, 1)) = runner Then
        MyCol.Add Trim(vals(i, 2)), Trim(vals(i, 2))
      End If
    Next
    On Error GoTo 0

    If MyCol.Count Then
      For Each runner In MyCol
        str = str & "," & runner
      Next

      With Range("E1").Validation
        .Delete
        .Add 3, 1, 1, Mid(str, 2)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
      End With
    End If
  End If
End Sub

使用您提供的數據對其進行了測試->行為符合預期。

編輯

對於排序，我建議稍微重寫一下子以使其較小（盡管有些東西不會那么明顯）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim vals As Variant, runner As Variant
  Dim MyCol As New Collection
  Dim str As String, str2 As String
  Dim i As Long
  Dim tp As Boolean

  If Not Intersect(Target, Union(Columns(1), Range("D1"))) Is Nothing Then

    Application.EnableEvents = False
    tp = Not Intersect(Target, Columns(1)) Is Nothing
    vals = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value2
    Range(Array("E1", "D1:E1")(-tp)).ClearContents
    runner = IIf(tp, " ", Range("D1").Value2)

    On Error Resume Next
    For i = 1 To UBound(vals)
      If (Trim(vals(i, 1)) = runner) Or (Len(Trim(vals(i, 1))) > 0 And tp) Then
        MyCol.Add Trim(vals(i, 2 + tp)), Trim(vals(i, 2 + tp))
      End If
    Next
    On Error GoTo 0

    If MyCol.Count Then

      While MyCol.Count
        str2 = ""

        For Each runner In MyCol
          If Len(str2) Then
            If StrComp(str2, runner) = 1 Then str2 = runner
          Else
            str2 = runner
          End If
        Next

        str = str & "," & str2
        MyCol.Remove str2
      Wend

      With Range(Array("E1", "D1")(-tp)).Validation
        .Delete
        .Add 3, 1, 1, Mid(str, 2)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
      End With
    End If

    Application.EnableEvents = True

  End If
End Sub

如果你有問題，就問吧 ;）