Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Brr, Z, i&
With Target
If .Address(0, 0) = "K2" Then
Brr = Range([C2], [C65536].End(3))
Set Z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Brr)
If Trim(Brr(i, 1)) <> "" Then Z(Trim(Brr(i, 1))) = ""
Next
With .Validation
.Delete
If Z.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(Z.KEYS(), ",")
Set Z = Nothing: Brr = Empty
End With
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Brr, Z, i&
With Target
If .Address(0, 0) = "K2" Then
Brr = Range([D2], [C65536].End(3))
Set Z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Brr)
If Brr(i, 1) = .Value And Trim(Brr(i, 2)) <> "" Then Z(Trim(Brr(i, 2))) = ""
Next
With [M2].Validation
.Delete
If Z.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(Z.KEYS(), ",")
Set Z = Nothing: Brr = Empty
End With
End If
If .Address(0, 0) = "M2" Then Call 列出明細
End With
End Sub作者: Andy2483 時間: 2024-1-18 09:22
Sub 列出明細()
Dim Brr, i&, K$, M$, T3$, T4$, A, N&, j%
Brr = Range([I2], [B65536].End(3)(1, 0))
Intersect([J:N], ActiveSheet.UsedRange).Offset(4).ClearContents
K = Trim([K2]): M = Trim([M2]): A = [{5,6,9,8,2}]
For i = 2 To UBound(Brr)
T3 = Trim(Brr(i, 3)): T4 = Trim(Brr(i, 4))
If T3 = K And T4 = M Then
N = N + 1
For j = 1 To 5: Brr(N, j) = Brr(i, A(j)): Next
End If
Next
If N = 0 Then Exit Sub Else [J5].Resize(N, 5) = Brr
Brr = Empty
End Sub
