' Place this at the top of the Sheet1 module (ONLY ONCE)
Dim oldValueDict As Object
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If oldValueDict Is Nothing Then Set oldValueDict =
CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In Target
If cell.Column = 2 Or cell.Column = 4 Then ' Column B and D
On Error Resume Next
oldValueDict(cell.Address) = cell.Value
On Error GoTo 0
End If
Next cell
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo CleanExit
Application.EnableEvents = False
Dim cell As Range
Dim fCell As Range
' --- Column B (2) logic: Update G364 ---
If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
For Each cell In Intersect(Target, Me.Columns("B"))
Dim oldValB As String
If Not oldValueDict Is Nothing Then
If oldValueDict.exists(cell.Address) Then oldValB =
oldValueDict(cell.Address)
End If
Dim newValB As String: newValB = cell.Value
If Trim(oldValB) = "" And Trim(newValB) <> "" Then
If IsNumeric(Range("G364").Value) Then
Range("G364").Value = Range("G364").Value + 1
Else
Range("G364").Value = 1
End If
ElseIf Trim(oldValB) <> "" And Trim(newValB) = "" Then
If IsNumeric(Range("G364").Value) And
Range("G364").Value > 0 Then
Range("G364").Value = Range("G364").Value - 1
Else
Range("G364").Value = 0
End If
End If
oldValueDict(cell.Address) = newValB
Next cell
End If
' --- Column D (4) logic: Update same row's F ---
If Not Intersect(Target, Me.Columns("D")) Is Nothing Then
For Each cell In Intersect(Target, Me.Columns("D"))
Dim oldValD As String
If Not oldValueDict Is Nothing Then
If oldValueDict.exists(cell.Address) Then oldValD =
oldValueDict(cell.Address)
End If
Dim newValD As String: newValD = cell.Value
Set fCell = cell.Offset(0, 2) ' Column F
If Trim(oldValD) = "" And Trim(newValD) <> "" Then
If IsNumeric(fCell.Value) Then
fCell.Value = fCell.Value + 1
Else
fCell.Value = 1
End If
ElseIf Trim(oldValD) <> "" And Trim(newValD) = "" Then
If IsNumeric(fCell.Value) And fCell.Value > 0 Then
fCell.Value = fCell.Value - 1
Else
fCell.Value = 0
End If
End If
oldValueDict(cell.Address) = newValD
Next cell
End If
CleanExit:
Application.EnableEvents = True
End Sub
