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
