' Declare this once at the very top of the worksheet module
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 ' B or 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, fCell As Range
Dim oldVal As String, newVal As String
' --- Column B → G3062 Counter ---
If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
For Each cell In Intersect(Target, Me.Columns("B"))
oldVal = ""
If Not oldValueDict Is Nothing Then
If oldValueDict.exists(cell.Address) Then oldVal = oldValueDict(cell.Address)
End If
newVal = cell.Value
If Trim(oldVal) = "" And Trim(newVal) <> "" Then
If IsNumeric(Range("G3062").Value) Then
Range("G3062").Value = Range("G3062").Value + 1
Else
Range("G3062").Value = 1
End If
ElseIf Trim(oldVal) <> "" And Trim(newVal) = "" Then
If IsNumeric(Range("G3062").Value) And Range("G3062").Value > 0 Then
Range("G3062").Value = Range("G3062").Value - 1
Else
Range("G3062").Value = 0
End If
End If
oldValueDict(cell.Address) = newVal
Next cell
End If
' --- Column D → same-row Column F counter ---
If Not Intersect(Target, Me.Columns("D")) Is Nothing Then
For Each cell In Intersect(Target, Me.Columns("D"))
oldVal = ""
If Not oldValueDict Is Nothing Then
If oldValueDict.exists(cell.Address) Then oldVal = oldValueDict(cell.Address)
End If
newVal = cell.Value
Set fCell = cell.Offset(0, 2) ' Column F
If Trim(oldVal) = "" And Trim(newVal) <> "" Then
If IsNumeric(fCell.Value) Then
fCell.Value = fCell.Value + 1
Else
fCell.Value = 1
End If
ElseIf Trim(oldVal) <> "" And Trim(newVal) = "" 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) = newVal
Next cell
End If
CleanExit:
Application.EnableEvents = True
End Sub
