Average not changing more than a certain number

[Iswearimnotdumb]

I'm working on a spreadsheet for my dad and I'm at a complete loss.

When a points score is entered, it automatically updates the Quota. I need a something so the quota does not go down more than 2 points.

We currently have a code on the sheet so when a new number is entered into the points column, it shifts the data into the "1" column and shifts the previous column 1 through 8 over to the right.

Current code is:

Private Sub Worksheet_Change(ByVal Target As Range) 'Excel VBA with more cells in the range.
'
If Not Intersect(Target, Range("B2:B55")) Is Nothing Then
Application.EnableEvents = False
'
Range("E" & Target.Row & ":M" & Target.Row).Cut Range("E" & Target.Row & ":M" & Target.Row).Cells(1).Offset(0, 1)
Range("E" & Target.Row) = Range("B" & Target.Row)
'
Application.EnableEvents = True
End If
End Sub

Any help would be greatly appreciated!!

WCC Dogfight_FORMULAS editing current.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Players	Points	Net +/-	Quota	1	2	3	4	5	6	7	8	9	10	Total
2	Allen, Frankie			20	18	19	19	22	23	21	19	23	19	18	201
3	Allman, Willie			28	27	30	19	31	27	27	30	32	28	28	279
Sheet1

Cell Formulas
Range	Formula
D2:D3	D2	=AVERAGE(INDEX($E:$E,ROW()):INDEX($N:$N,ROW()))
O2:O3	O2	=SUM(INDEX($E:$E,ROW()):INDEX($N:$N,ROW()))

 

[rlv01]

You could detect the large quota change with something like this.

Private Sub Worksheet_Change(ByVal Target As Range) 'Excel VBA with more cells in the range.
    '
    Dim LastQuota As Double, VA As Variant
    
    If Not Intersect(Target, Range("B2:B55")) Is Nothing And Target.Cells.Count = 1 Then
        LastQuota = Target.Offset(0, 2).Value
        VA = Target.Offset(0, 3).Resize(1, 10).Value
        
        Application.EnableEvents = False
        '
        Range("E" & Target.Row & ":M" & Target.Row).Cut Range("E" & Target.Row & ":M" & Target.Row).Cells(1).Offset(0, 1)
        Range("E" & Target.Row) = Range("B" & Target.Row)
        '
        Application.EnableEvents = True
        
        If LastQuota - Target.Offset(0, 2).Value > 2 Then
            Select Case MsgBox("New quota (" & Target.Offset(0, 2).Value & ") is less than previous quota (" & LastQuota & ") by more than 2. " & vbCrLf & vbCrLf _
                    & "Continue?" & vbCrLf _
                    & "('Cancel' to restore old quota)", vbOKCancel + vbQuestion + vbDefaultButton2, Application.Name)
                Case vbCancel
                    Application.EnableEvents = False
                    Target.Offset(0, 3).Resize(1, 10).Value = VA
                    Target.Value = ""
                    Application.EnableEvents = True
            End Select
        End If
    End If
End Sub

 

[Snakehips]

I was thinking maybe....?

Private Sub Worksheet_Change(ByVal Target As Range) 'Excel VBA with more cells in the range.

If Not Intersect(Target, Range("B2:B55")) Is Nothing Then
Application.EnableEvents = False
Dim r As Integer
Dim OldQuota As Single
Dim NewQuota As Single

r = Target.Row
OldQuota = Range("D" & r)


Range("F" & r & ":N" & r).Value = Range("E" & r & ":M" & r).Value
Range("E" & r) = Range("B" & r)

NewQuota = WorksheetFunction.Average(Range("E" & r & ":N" & r))

Range("D" & r) = WorksheetFunction.Max(NewQuota, OldQuota - 0.2)
'
Application.EnableEvents = True
End If
End Sub