Changing a series/list of values while maintaining list total and proportionality

Try pasting this into the Sheet1 tab of the VBA editor (Alt F11).

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Cell2 As Range
Dim DataRange As Range
Dim VOld
Dim VNew
Dim Difference

Set DataRange = Range("A1:D5")


For Each Cell In Target
    If Intersect(Cell, DataRange) Is Nothing = False Then
        
        VNew = Cell.Value
        Application.EnableEvents = False
        Application.Undo
        VOld = Cell.Value
        Cell = VNew
        Application.EnableEvents = True
        
        Difference = VNew - VOld
        
        For Each Cell2 In DataRange.Columns(Cell.Column).Cells
            If Cell2.Address <> Cell.Address Then
                Application.EnableEvents = False
                Cell2 = Cell2 - Difference / (DataRange.Columns(Cell.Column).Cells.Count - 1)
                Application.EnableEvents = True
            End If
            
        Next Cell2
    End If
Next Cell
End Sub

This should alter values in the same column to keep the same total by splitting the difference between them.

As written, it splits the difference evenly between the remaining items in the column.

For a proportional change you could try something like

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Cell2 As Range
Dim DataRange As Range
Dim Total
Dim VOld
Dim VNew
Dim Difference
Dim Factor

Set DataRange = Range("A1:D5")


For Each Cell In Target
    If Intersect(Cell, DataRange) Is Nothing = False Then
        
        VNew = Cell.Value
        Application.EnableEvents = False
        Application.Undo
        VOld = Cell.Value
        Cell = VNew
        Application.EnableEvents = True
        
        Difference = VNew - VOld
        For Each Cell2 In DataRange.Columns(Cell.Column).Cells
            If Cell2.Address <> Cell.Address Then
                Total = Total + Cell2
            End If
        Next Cell2
        Factor = (Total - Difference) / Total
        
        For Each Cell2 In DataRange.Columns(Cell.Column).Cells
            If Cell2.Address <> Cell.Address Then
                Application.EnableEvents = False
                Cell2 = Cell2 * Factor
                Application.EnableEvents = True
            End If
        Next Cell2
    End If
Next Cell
End Sub