Private Sub Worksheet_Change(ByVal Target As Range)
'
If Target.Cells.Count = 1 Then ' If only one cell changed then ...
If Not Intersect(Target, Range("D4:G4")) Is Nothing Then ' If the Target cell is in the SumRange then ...
Dim BlanksInRange As Long
BlanksInRange = WorksheetFunction.CountBlank(Range("D4:G4")) ' Get count of blank cells in the SumRange
'
Application.EnableEvents = False ' Turn off EnableEvents to prevent recursive looping
'
If BlanksInRange = 0 Then GoTo NoBlankInRangeErrorHandler ' If no blanks in the SumRange then goto NoBlankInRangeErrorHandler
If BlanksInRange = 1 Then GoTo CheckForDesiredNewEntries ' If only 1 blank in the SumRange then goto CheckForDesiredNewEntries
'
NormalProcessing:
Select Case BlanksInRange
Case 1 ' If only 1 blank cell in the SumRange then ...
Dim MissingCell As String
MissingCell = Range("D4:G4").SpecialCells(xlCellTypeBlanks).Address(0, 0) ' Set MissingCell = the blank cell address found
'
Select Case MissingCell
Case "D4" ' If MissingCell = D4 then ...
Range("D4").Formula = "=Sum(E4:G4)" ' Set D4 = Sum(E4:G4
Case "E4" ' If MissingCell = E4 then ...
Range("E4").Formula = "=Sum(D4,-F4,-G4)" ' Set E4 = D4 - F4 - G4
Case "F4" ' If MissingCell = F4 then ...
Range("F4").Formula = "=Sum(D4,-E4,-G4)" ' Set F4 = D4 - E4 - G4
Case "G4" ' If MissingCell = G4 then ...
Range("G4").Formula = "=Sum(D4,-E4,-F4)" ' Set G4 = D4 - E4 - F4
End Select
'
Range("D4:G4").Value = Range("D4:G4").Value ' Clear formulas from SumRange, leave just the values
End Select
End If
End If
'
Application.EnableEvents = True ' Turn EnableEvents back on
Exit Sub
'
NoBlankInRangeErrorHandler: ' No blanks found in the SumRange after a change so ...
Application.Undo ' Undo the last change
Application.EnableEvents = True ' Turn EnableEvents back on
Exit Sub
'
CheckForDesiredNewEntries: ' One blank found in the SumRange after a change so ...
Application.Undo ' Undo the last change
'
BlanksInRange = WorksheetFunction.CountBlank(Range("D4:G4")) ' Do a new check for # of blanks in the SumRange
'
If BlanksInRange = 0 Then ' If BlanksInRange = 0 then ... User probably wanting to delete/restart
Application.Undo ' Undo the last change
Application.EnableEvents = True ' Turn EnableEvents back on
Exit Sub
Else ' Else ...
If BlanksInRange = 2 Then ' User probably still entering initial values
Application.Undo ' Undo the last change
'
BlanksInRange = WorksheetFunction.CountBlank(Range("D4:G4")) ' Do a new check for # of blanks in the SumRange
GoTo NormalProcessing
End If
End If
End Sub
