Distribute a quantity value in a cell into other cells (is it even possible?)

[edge37]

Hello, is it possible to distribute a value in a cell (in my case they are extra points) between other cells that already have a note (but not going above the maximum value assigned)? In my gradebook I have a cell with extra points, and I want to distribute them between the assignments that I already graded. As you can see in the example I sent, I have 5 and 3 extra points for each student, HW1 max value in John's grades is 7 points, but he got only 6, so the macro would add 1 point more so the value would reach 7. Then 4 extra points are remaining, so the same would be with other cells until those 5 extra points are distributed. If a cell has the maximun number of points then nothing would happen there, if the cell value is below the max then the extras could be distributed there. If there is no room for more points then the value of extras wouldn't change, if all extra points are distributed the Extra Point cell will show a 0.

I've never heard of this before, but, if possible, can you help me with a macro to do this for all students?

example.xlsx
	A	B	C	D	E	F	G	H	I	J
1	Name	HW 1	HW 2	HW 3	HW 4	HW 5	HW 6	HW 7		XTRA
2		7 points	5 points	5 points	5 points	6 points	7 points	8 points
3	John	6	3	4	3	6	0	8		5
4	Mary	7	5	2	1	6	7	8		3
Sheet1

 

[Peter_SSs]

See if this is what you want then.

Sub Distribute_Extras_v2()
  Dim p As Variant, Maxp As Variant, x As Variant
  Dim i As Long, j As Long, ubp2 As Long
  
  With Range("C9:K38")
    p = .Value
    ubp2 = UBound(p, 2)
    Maxp = .Rows(0).Value
    x = Intersect(.EntireRow, Columns("O")).Value
    For i = 1 To UBound(p)
    j = 1
      Do While x(i, 1) > 0 And j <= ubp2
        If p(i, j) < Maxp(1, j) Then
          p(i, j) = p(i, j) + 1
          x(i, 1) = x(i, 1) - 1
        End If
        If p(i, j) = Maxp(1, j) Then j = j + 1
      Loop
    Next i
    .Value = p
    Intersect(.EntireRow, Columns("O")).Value = x
  End With
End Sub

This is the result of the above code using the data from post 10.

edge37.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
7			HW1	HW2	HW3	HW4	HW5	HW6	HW7	HW8		IP	IP 2	VAL	EXTRA POINTS
8	#	NOMBRE DEL ESTUDIANTE	5	5	5	5	5	5	8	7		5	5	10	X
9	1	Olivia	5	5	5	5	5	5	8	7					5
10	2	Ethan	5	5	5	5	5	5	8	7					4
11	3	Sophia	5	5	5	5	5	5	8	7					3
12	4	Liam	5	5	0	4	4	5	8	6
13	5	Ava	5	4	4	3	4	4	8	5
14	6	Mason	5	5	5	0	5	0	8	0					0
15	7	Emma	5	5	5	5	5	5	8	7					4
16	8	Noah	5	5	5	5	5	5	8	7					3
17	9	Isabella	5	5	5	5	5	5	8	7					2
18	10	Lucas	5	1	3	3	5	0	8	0					0
19	11	Mia	5	2	0	2	0	5	8	0					0
20	12	Elijah	5	5	5	5	5	5	8	7					4
21	13	Charlotte	5	5	5	5	5	5	8	7					3
22	14	Benjamin	5	5	5	5	5	5	8	7					2
23	15	Harper	5	5	5	3	4	3	4	6
24	16	Oliver	5	5	5	5	5	5	8	7					4
25	17	Amelia	5	5	5	5	4	4	8	7					0
26	18	Henry	5	5	5	5	5	5	8	7					2
27	19	Grace	5	5	4	4	3	3	7	5					0
28	20	William	5	5	5	4	4	5	8	7					0
29	21	Abigail	5	5	5	5	5	5	8	7					3
30	22	Alexander	2	5	5	5	5	5	8	7					0
31	23	Ella	5	1	0	0	5	4	6	3					0
32	24	James	5	5	5	5	5	5	8	7					4
33	25	Chloe	5	5	4	2	5	5	8	6					0
34
35
36
37
38
Post 10 (2)

 

[edge37]

Wow, fantastic! Works exactly like I need it to. I appreciate your assistance very much.

Thank you again, Peter_SSs

By the way, I'm trying to mark your post as the solution, I confirm such action and the post doesn't get marked. I'll keep trying

 

[edge37]

Modified Code. Try.

Sub DistributeExttra()
Dim D, X, MaxPts, A
Dim Tr&, Tc&, Lr&

D = Range("B3:H4"): X = Range("J3:J4"): MaxPts = Range("B2:H2")
Lr = Range("A" & Rows.Count).End(xlUp).Row
For Tr = 1 To UBound(D, 1)
A = True
    For Tc = 1 To UBound(D, 2)
    If X(Tr, 1) = 0 Then Exit For
    If D(Tr, Tc) < MaxPts(1, Tc) Then
    D(Tr, Tc) = D(Tr, Tc) + 1
    X(Tr, 1) = X(Tr, 1) - 1
    If D(Tr, Tc) < MaxPts(1, Tc) Then A = False
    End If
    Next Tc
If X(Tr, 1) > 0 And A = False Then Tr = Tr - 1
Next Tr
Range("B3:H4") = D: Range("J3:J4") = X
End Sub

Thank you for your work, kvsrinivasamurthy
I tried both your codes and I noticed that if I increase the extra points when the code distributes them, they exceed the maximum points for the HW, also when when deleting one student's grades, or when deleting one HW the code do not work. Could this be fixed?

 

[kvsrinivasamurthy]

In B2:H2 enter only numbers. Avoid text.
Then run the code.

 

[Peter_SSs]

Wow, fantastic! Works exactly like I need it to. I appreciate your assistance very much.

Thank you again, @Peter_SSs

You are welcome. Thanks for the follow-up.

By the way, I'm trying to mark your post as the solution, I confirm such action and the post doesn't get marked. I'll keep trying

We have seen that happen a couple of times and are investigating. On this occasion I have marked the post for you.