下拉選擇的驗證

Question

我在每列的每個單元格中都有下拉列表。 如果我在流程 1 下為批次代碼 BOL 選擇說 GR1，我可以將 GR1 用於該批次代碼，但不能用於任何其他批次代碼。

一旦我為除 BOL 之外的任何其他批次代碼在任何其他過程中的任何其他地方選擇 GR1，我應該收到一個錯誤，指出我無法選擇它。

也只是為了明確下拉列表中的值已根據數組中的條件填充。

目前我可以在整個工作表中選擇相同的值。

請在下拉列表中找到用於生成值的代碼

Option Explicit

Sub try()

Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Range
Dim st, gr, bl, rc, co, ec, ct As Object

ThisWorkbook.Sheets("P").Range("E2:K150").Clear

For i = 2 To 160

Set st = CreateObject("System.Collections.ArrayList")
Set gr = CreateObject("System.Collections.ArrayList")
Set bl = CreateObject("System.Collections.ArrayList")
Set rc = CreateObject("System.Collections.ArrayList")
Set co = CreateObject("System.Collections.ArrayList")
Set ec = CreateObject("System.Collections.ArrayList")
Set ct = CreateObject("System.Collections.ArrayList")

For j = 5 To 160

If (ThisWorkbook.Sheets("P").Cells(i, 1) = ThisWorkbook.Sheets("M").Cells(j, 1)) Then

For k = 6 To 160

If (ThisWorkbook.Sheets("M").Cells(j, k) <> "") Then

For Each c In ThisWorkbook.Sheets("M").Cells(1, k)

Select Case c.Value

Case "S"
st.Add ThisWorkbook.Sheets("M").Cells(3, k).Value
Case "G"
gr.Add ThisWorkbook.Sheets("M").Cells(3, k).Value
Case "B"
bl.Add ThisWorkbook.Sheets("M").Cells(3, k).Value
Case "R"
rc.Add ThisWorkbook.Sheets("M").Cells(3, k).Value
Case "C"
co.Add ThisWorkbook.Sheets("M").Cells(3, k).Value
Case "E"
ec.Add ThisWorkbook.Sheets("M").Cells(3, k).Value
Case "Co"
ct.Add ThisWorkbook.Sheets("M").Cells(3, k).Value

End Select

Next c

End If

Next k

End If

Next j

Range("P!E" & i).Clear
Range("P!F" & i).Clear
Range("P!G" & i).Clear
Range("P!H" & i).Clear
Range("P!I" & i).Clear
Range("P!J" & i).Clear
Range("P!K" & i).Clear

If (st.Count <> 0) Then

Range("P!E" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(st.toarray, ",")

End If

If (gr.Count <> 0) Then

Range("P!F" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(gr.toarray, ",")

End If

If (bl.Count <> 0) Then

Range("P!G" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(bl.toarray, ",")

End If

If (rc.Count <> 0) Then

Range("P!H" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(rc.toarray, ",")

End If

If (co.Count <> 0) Then

Range("P!I" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(co.toarray, ",")

End If

If (ec.Count <> 0) Then

Range("P!J" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(ec.toarray, ",")

End If

If (ct.Count <> 0) Then

Range("P!K" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(ct.toarray, ",")

End If

Set st = Nothing
Set gr = Nothing
Set bl = Nothing
Set rc = Nothing
Set co = Nothing
Set ec = Nothing
Set ct = Nothing

Next i

End Sub

Answer 1

這可能會奏效。

編輯：

如果與所選單元格在同一行，則保留驗證標准

使用Worksheet_SelectionChange事件即時修改驗證列表。

例如：

下面的代碼是作為數據驗證范圍的工作表代碼輸入的。

它假設您已經按照您在問題中的描述進行了設置。

'myList and myRange are assumed to be named ranges in your workbook referring
'to the full Validation List and the Range over which the
'Validation is to be applied.
'
'You can refer to them by other means, depending on your setup
'
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim col As Collection
  Dim V, W, X, I As Long

On Error GoTo Err

If Selection.Count > 1 Then Set Target = Selection(1, 1)
Target.Select

If Not Intersect(Target, [myrange]) Is Nothing Then
    Set col = New Collection
    With [myrange]
        For Each V In [mylist] 'or however the validation list is set up
            If .Find(what:=V, after:=.Item(1), LookIn:=xlValues, _
                lookat:=xlWhole, MatchCase:=True) Is Nothing Then
                    col.Add V, V
            End If
        Next V

        'Add contents of any cell in same row as target
        For Each W In Intersect([myrange], Target.EntireRow).Cells
            If Len(W.Value) > 0 Then
                For Each V In [mylist]
                    If V = W.Value Then col.Add W, W
                Next V
            End If
        Next W
    End With

    ReDim W(1 To col.Count)
    I = 0
    For Each V In col
        I = I + 1
        W(I) = V
    Next V

    customSort W, [mylist]

'Can either modify the pre-existing validation or,
' may be safer to just set up a new validation on-the-fly

'Target.Validation.Modify Formula1:=Join(W, ",")

' may be safer to just set up a new validation on-the-fly

'Set up new validation
With Target.Validation
    .Delete
    .Add Type:=xlValidateList, _
            AlertStyle:=xlValidAlertStop, _
            Formula1:=Join(W, ",")
End With

End If
Exit Sub

Err:
Select Case Err.Number
    Case 457 'don't add duplicate strings
        Resume Next
    Case Else
        MsgBox "Error number: " & Err.Number & vbLf & Err.Description
End Select

End Sub

'Maintain dropdown in same order as original list
Sub customSort(arrToSort, arrOrder)
  Dim col As Collection
  Dim V, W, I As Long

Set col = New Collection
For Each W In arrOrder
    For Each V In arrToSort
        If V = W Then
            col.Add V
        End If
    Next V
Next W

I = LBound(arrToSort)
For Each V In col
    arrToSort(I) = V
    I = I + 1
Next V

End Sub

Answer 2

我找到了我在上面的評論中提到的代碼並對其進行了消毒。 第一部分進入工作表的代碼模塊。

Option Explicit

    Dim PrevCell As Range

Private Sub Worksheet_Activate()
    ' 26 Mar 2015
    SetFilter Account
    Set PrevCell = Cells(1, 1)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 24 Apr 2015

    Dim Clm() As Variant
    Dim Lid() As Variant
    Dim GotVal As Boolean
    Dim Rng As Range
    Dim R As Long
    Dim C As Long

    If Target.Cells.CountLarge > 1 Then Exit Sub

    ' setting the columns in which to set validation
    Set Rng = Application.Union(AccRange(2), _
                                AccRange(4), _
                                AccRange(5), _
                                AccRange(8))
    Application.EnableEvents = False
    On Error GoTo NoPrevCell

    ' delete existing validation in the previously selected cell
    If Insect(PrevCell, Rng) = False Then SetValidation PrevCell, Del:=True

    GetProps Target, R, C
    If Not Application.Intersect(Target, Rng) Is Nothing Then
        SetValidation Target, 3, 1
    End If

    Set PrevCell = Target

SideExit:
    Application.EnableEvents = True
    Exit Sub

NoPrevCell:
    Set PrevCell = Cells(1, 1)
    Resume 0
End Sub

以下是運行代碼所需的支持過程。 出於兩個原因，我在那里留下了比顯然需要的更多的代碼。 一，刪除它需要時間。 第二，你可能會使用我五年前使用的一些方法。

Function AccRange(Optional C As Long, _
              Optional Rl As Long, _
              Optional Ct As Long = 3) As Range
' 23 Mar 2015
' Return only column C, if specified
' Use column Ct to determine the last row, if Rl isn't specified

Ct = WorksheetFunction.Max(Ct, 1)
With Worksheets("Account")
    If Rl = 0 Then Rl = .Cells(.Rows.Count, Ct).End(xlUpt).Row
    Set AccRange = .Range(.Cells(2, C), .Cells(Rl, C))
End With

結束函數

函數 GetProps（目標作為范圍，_ 可選 R 作為長，_ 可選 C 作為長，_ 可選 V 作為變體，_ 可選 W 作為工作表）' 2015 年 5 月 22 日

With Target
    R = .Row
    C = .Column
    V = .Value
    Set Ws = .Worksheet
End With

結束函數

Sub SetValidation(Tgt As Range, _ Optional Lid As Nnr, _Optional Lclm As Long, _Optional SelectOnly As Boolean, _ Optional Del As Boolean) ' 07 Apr 2015 '在 Tgt 中設置或刪除驗證

' Tgt is a cell requiring validation
' Lid identifies a named range containing a list
' Lclm identifies a column within that named range
' SelectOnly sets Error behaviour
' If Del = True the existing validation is deleted
'   without setting a new one.

Dim Lv As String

With Tgt.Validation
    .Delete

    If Not Del Then
        Lv = GetListValues(Lid, Lclm)
        .Add Type:=xlValidateList, Formula1:=Lv
        .InCellDropdown = True
        .ShowInput = True
        .IgnoreBlank = False
        .ShowError = SelectOnly
        If SelectOnly Then
            .ErrorTitle = "Required entry"
            .ErrorMessage = "Please select an existing list item."
        End If
    End If
End With

結束子

私有函數 GetListValues(Lid As Nnr, _ Lclm As Long) As String ' 2015 年 4 月 7 日

' Lid identifies a named range containing a list
' Lclm identifies a column within that named range

Dim Fun As String                       ' Function return value
Dim Itm As String                       ' List Item
Dim i As Long

Lclm = WorksheetFunction.Max(Lclm, 1)

With ListRange(Lid).Columns(Lclm)       ' returns the list
    For i = 1 To .Cells.Count
        Itm = Trim(.Cells(i).Value)
        If Len(Itm) Then
            Fun = Fun & .Cells(i).Value & Sep
        Else
            Exit For
        End If
    Next i
    If (Lid = 3) And (Lclm = 1) And _
       (CountA(ListRange(3).Columns(1)) > 0) Then
       ' add an item to the list under special circumstances
        Fun = Fun & "Special item" & Sep
    End If
End With

GetListValues = Left(Fun, Len(Fun) - 1)

結束函數

函數 Sep() As String ' 2015 年 2 月 22 日

Sep = Application.International(xlListSeparator)

結束函數

抱歉，SO 不允許我發布原始代碼的格式。