Question

我正在尝试自动更新对其具有数据验证限制的单元格。例如 - Sheet1 有下面的列（E 列）：

<头>

包标识符
A
B
C

其中值取自 Sheet2 中同名列（D 列）。以下代码仅适用于手动更改

Sheet2 Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim count_cells As Integer
Dim new_value As String
Dim old_value As String
Dim rng As Range
For count_cells = 1 To Range("D1").CurrentRegion.Rows.Count - 1
    Set rng = Worksheets("Sheet1").Range("E3:E86")
    If Intersect(Target, Range("D" & count_cells + 1)) Is Nothing Then
    Else
        Application.EnableEvents = False
        new_value = Target.Value
        Application.Undo
        old_value = Target.Value
        Target.Value = new_value
        rng.Replace What:=old_value, Replacement:=new_value, LookAt:=xlWhole
        Target.Select
    End If
Next count_cells
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

因此，如果我手动将值 B 更改为 Z，则 Sheet1 上所有对应的 B 值现在都更改为 Z。问题是，Sheet2 上的 Package Identifier 是由连接其他列决定的

=CONCATENATE(B35, "-", "Package", "-", TEXT(C35, "#000"))

当尝试将其与上述公式一起使用时，这段代码会中断。我怎样才能在这个基于公式的输出上触发这组代码？

Answer 1

假设这是验证表的样子

这是源表的外观

假设用户选择了验证表中的第一个选项。

现在返回源表并将单元格1中的2更改为C2。

注意验证表中发生的事情

如果这是您正在尝试的内容，请根据您提供的文件测试此代码。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim aCell As Range
    Dim NewSearchValue As String
    Dim OldSearchValue As String
    Dim NewArrayBC As Variant
    Dim OldArrayA As Variant, NewArrayA As Variant
    Dim lRow As Long, PrevRow As Long
    
    On Error GoTo Whoa

    Application.EnableEvents = False
    
    If Not Intersect(Target, Range("B:C")) Is Nothing Then
        lRow = Range("A" & Rows.Count).End(xlUp).Row
        
        '~~> Store new values from Col A, B and C in an array
        NewArrayBC = Range("B1:C" & lRow).Value2
        NewArrayA = Range("A1:A" & lRow).Value2
        
        Application.Undo
        
        '~~> Get the old values from Col A
        OldArrayA = Range("A1:A" & lRow).Value2
        
        '~~> Paste the new values in Col B/C
        Range("B1").Resize(UBound(NewArrayBC), 2).Value = NewArrayBC
        
        '~~> Loop through the cells
        For Each aCell In Target.Cells
            '~~> Check if the prev change didn't happen in same row
            If PrevRow <> aCell.Row Then
                PrevRow = aCell.Row
            
                NewSearchValue = NewArrayA(aCell.Row, 1)
                OldSearchValue = OldArrayA(aCell.Row, 1)
    
                Worksheets("Validation").Columns(2).Replace What:=OldSearchValue, _
                Replacement:=NewSearchValue, Lookat:=xlWhole
            End If
        Next aCell
    End If
Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

Answer 2

与 Sid 不同的方法...

这不是在源范围更改时更新 DV 单元格中的值，而是使用指向 DV 源范围中匹配单元格的链接替换所选值。

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rngV As Range, rng As Range, c As Range, rngList As Range
    Dim f As Range
    
    On Error Resume Next
    'any validation on this sheet?
    Set rngV = Me.Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0
    If rngV Is Nothing Then Exit Sub 'no DV cells...
    
    Set rng = Application.Intersect(rngV, Target)
    If rng Is Nothing Then Exit Sub 'no DV cells in Target
    
    For Each c In rng.Cells
        If c.Validation.Type = xlValidateList Then 'DV list?
            Set rngList = Nothing
            On Error Resume Next
            'see if we can get a source range
            Set rngList = Evaluate(c.Validation.Formula1)
            On Error GoTo 0
            If Not rngList Is Nothing Then
                Application.EnableEvents = False
                'find cell to link to
                Set f = rngList.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not f Is Nothing Then
                    Application.EnableEvents = False
                    c.Formula = "='" & f.Parent.Name & "'!" & f.Address(0, 0)
                    Application.EnableEvents = True
                End If
            Else
                Debug.Print "No source range for " & c.Address
            End If
        End If
    Next c
End Sub

源值更改时自动更新验证单元格

2 个答案: