Option Explicit
Private Sub Worksheet_Activate()
Dim Arr(), I As Long, Dic As Object
Arr = Sheet1.Range(Sheet1.[P5], Sheet1.[P65000].End(3)).Value
Set Dic = CreateObject("scripting.dictionary")
For I = 1 To UBound(Arr)
Dic(Arr(I, 1)) = ""
Next I
Range("G1").Validation.Delete
Range("G1").Validation.Add 3, , , Join(Dic.keys, ",")
Range("G1").Font.Bold = True
Range("G1").Interior.ColorIndex = 6
Set Dic = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr, dArr, I&, K&, NV, Tong&
NV = [G1].Value
With Sheet1
Arr = .Range(.[B5], .[B65000].End(3)).Resize(, 16).Value
End With
ReDim dArr(1 To UBound(Arr), 1 To 5)
Application.ScreenUpdating = False
If Target.Address = "$G$1" Then
For I = 1 To UBound(Arr)
If Arr(I, 15) = NV And Arr(I, 14) > 0 Then
K = K + 1
dArr(K, 1) = K
dArr(K, 2) = Arr(I, 1)
dArr(K, 3) = Arr(I, 2)
dArr(K, 4) = Arr(I, 3)
dArr(K, 5) = Arr(I, 14)
Tong = Tong + Arr(I, 14)
End If
Next I
dArr(K + 1, 2) = "T" & ChrW(7893) & "ng "
dArr(K + 1, 5) = Tong
If [A65000].End(3).Row > 5 Then
Range([A6], [B65000].End(3)).Resize(, 5).Borders.LineStyle = 0
Range([A6], [B65000].End(3)).Resize(, 5).ClearContents
End If
If K Then
Range("A6").Resize(K + 1, 5) = dArr
Range("A6").Resize(K + 1, 5).Borders.LineStyle = 1
End If
End If
Application.ScreenUpdating = True
End Sub
