Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long
lastR = Me.Range("A" & Me.rows.count).End(xlUp).Row
If Not Intersect(Target, Me.Range("B2:C" & lastR)) Is Nothing Then
If Me.Range("E1").Value = "" Then Me.Range("E1:F1").Value = Array("B Validation", "C Validation")
Dim arrAC, arrRet, i As Long, k As Long
arrAC = Me.Range("A2:C" & lastR).Value2
ReDim arrRet(UBound(arrAC) - 1)
For i = 1 To UBound(arrAC)
If arrAC(i, Target.column) = "x" Then arrRet(k) = arrAC(i, 1): k = k + 1
Next i
If k > 0 Then
ReDim Preserve arrRet(k - 1)
With Me.cells(2, Target.column + 3).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:=Join(arrRet, ",")
End With
Else
Me.cells(2, Target.column + 3).Validation.Delete
End If
End If
End Sub
1条答案
按热度按时间x8diyxa71#
为了在B:C列中放置或清除“x”时自动创建/修改列表验证单元格,请复制相应表单代码模块中的下一个代码。它将在“E2”中创建两个列表数据验证单元格,分别为“F2”: