各位論壇前輩好
以下的學習方案請各位前輩提供建議,謝謝各位
 20230719_2.zip (12.81 KB)
原始排程:
在B6儲存格輸入 1 後更新結果:
Option Explicit
Dim xA As Range, Brr, Z, T0$, V%
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If .Column <> 2 Or .Row = 1 Or .Count > 1 Then Exit Sub
Set xA = Range([D2], [a65536].End(3))
If Not Intersect(.Cells, xA) Is Nothing Then
Brr = xA: T0 = .Cells(1, 0): V = .Value
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Crr, V1%, T1$, i&, Q%, T$, TT$, S$, SS$, N%
With Target
If .Column <> 2 Or .Row = 1 Or .Count > 1 Then Exit Sub
If Not Intersect(.Cells, xA) Is Nothing Then
T1 = .Cells(1, 0): V1 = .Value
For i = 1 To UBound(Brr)
If Brr(i, 1) = T0 Then
If Brr(i, 2) = V Then
Brr(i, 2) = V1
ElseIf Brr(i, 2) >= V And Brr(i, 2) <= V1 Then
Brr(i, 2) = Brr(i, 2) - 1
Else
If Brr(i, 2) + Q = V1 Then Q = Q + 1
Brr(i, 2) = Brr(i, 2) + Q
End If
End If
Next
With xA
.Value = Brr
.Sort KEY1:=.Item(1), Order1:=1, _
Key2:=.Item(2), Order2:=1, Header:=2
End With
Crr = xA
For i = 1 To UBound(Crr)
T = Crr(i, 1): TT = T & "\" & Crr(i, 2)
N = N * -(T = S) - (TT <> SS)
S = T: SS = TT
Crr(i, 2) = N
Next
xA = Crr
End If
End With
Set xA = Nothing: Erase Brr, Crr
End Sub
謝謝論壇 |
發表於 2023-7-19 10:09
| 
