工作表变更：自动验证

的数据

事件（调用）过程：薄板模块，例如Sheet3(3)

Private Sub Worksheet_Change(ByVal Target As Range)
    UpdateValidationList Target
End Sub

字符串

标准模块中的外部事件测试器，例如Module1

Sub Tester()
    ' Mimic the change event.
    Dim Target As Range: Set Target = ThisWorkbook.Sheets("3").Range("C8")
    ' Apply validation.
    UpdateValidationList Target
End Sub

型

**标准模块中的方法，例如Module1

Sub UpdateValidationList(ByVal Target As Range)
    
    Const PROC_TITLE As String = "Update Validation List"
    Const SRC_FIRST_CELL As String = "C8"
    Const DST_SHEET As String = "4"
    Const DST_RANGE As String = "C8:C20"
    
    Dim sws As Worksheet: Set sws = Target.Worksheet
    
    Dim scrg As Range ' C8:C1048576
    
    With sws.Range(SRC_FIRST_CELL)
        Set scrg = .Resize(sws.Rows.Count - .Row + 1)
    End With
    
    Dim srg As Range: Set srg = Intersect(scrg, sws.UsedRange)
    
    If srg Is Nothing Then
        MsgBox "The range """ & scrg.Address(0, 0) & """ of worksheet """ _
            & sws.Name & """ is empty!", _
            vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    If Intersect(srg, Target) Is Nothing Then Exit Sub ' no source cell changed
    
    Dim srCount As Long: srCount = srg.Rows.Count
    
    If Application.CountBlank(srg) = srCount Then
        MsgBox "The range """ & srg.Address(0, 0) & """ of worksheet """ _
            & sws.Name & """ is blank!", _
            vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    Dim sData() As Variant:
    
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim rVal As Variant, r As Long, rStr As String
    
    For r = 1 To srCount
        rVal = sData(r, 1)
        If Not IsError(rVal) Then
            rStr = CStr(rVal)
            If Len(rStr) > 0 Then
                If Not dict.Exists(rStr) Then ' ensuring the first occurrence
                    dict(rStr) = Empty
                End If
            End If
        End If
    Next r

    Erase sData
    
    If dict.Count = 0 Then
        MsgBox "The range """ & srg.Address(0, 0) & """ of worksheet """ _
            & sws.Name & """ contains error values but no non-blanks!", _
            vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    Dim ValidationList As String: ValidationList = Join(dict.Keys, ",")
    
    Dim dws As Worksheet: Set dws = sws.Parent.Worksheets(DST_SHEET)
    Dim drg As Range: Set drg = dws.Range(DST_RANGE)
    
    With drg.Validation
        .Delete
        .Add xlValidateList, xlValidAlertStop, xlBetween, ValidationList
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With

End Sub

型

STEP1：将Sub setupDV()放入module中，以从Change事件调用。
STEP2：为Sheets（“3”）添加Change事件处理程序。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    Set r = Application.Intersect(Target, Me.Range("C8:C1000"))
    If Not r Is Nothing Then
        Application.EnableEvents = False
            Call setupDV
        Application.EnableEvents = True
    End If
End Sub

字符串
顺便说一句，你可以最小化setupDV()中的rSource范围以提高性能。

With Sheets("3")
        Set rSource = Application.Intersect(.Range("C8:C1000"), .UsedRange)
    End With

型