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

 

[Michael M]

I see what you are trying to achieve, but which students get the extra point, as there are 7 students and only 5 points ??

 

[Skyybot]

Why wouldn't all 5 of John's extra points go to HW6? Seems that would be best for John.

 

[Peter_SSs]

See if this does what you want. Test with a copy of your worksheet.

Sub Distribute_Extras()
  Dim p As Variant, Maxp As Variant, x As Variant
  Dim i As Long, j As Long, ubp2 As Long
  
  With Range("B3", Range("B3").End(xlToRight)).Resize(Range("A" & Rows.Count).End(xlUp).Row - 2)
    p = .Value
    ubp2 = UBound(p, 2)
    Maxp = .Rows(0).Value
    For j = 1 To ubp2
      Maxp(1, j) = Val(Split(Maxp(1, j))(0))
    Next j
    x = .Offset(, .Columns.Count + 1).Resize(, 1).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
    .Offset(, .Columns.Count + 1).Resize(, 1).Value = x
  End With
End Sub

Here is my sheet after the code has been run

edge37.xlsm
	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	7	5	5	4	6	0	8		0
4	Mary	7	5	5	1	6	7	8		0
5
Sheet1

 

[Peter_SSs]

I am not sure what is possible with your data, but here I have added some other scenarios, including where not all the extra points can be used - as I understand it.
Same code as above.
Before:

edge37.xlsm
	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
5	Deb	6	5	5	4	3	0	7		20
6	Kim	3	3	3	3	0	3	3		0
7	Tom	7	5	5	5	6	7	8		5
Sheet3

After:

edge37.xlsm
	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	7	5	5	4	6	0	8		0
4	Mary	7	5	5	1	6	7	8		0
5	Deb	7	5	5	5	6	7	8		7
6	Kim	3	3	3	3	0	3	3		0
7	Tom	7	5	5	5	6	7	8		5
Sheet3

 

[kvsrinivasamurthy]

Try.

Sub DistributeExttra()
Dim D, X, MaxPts
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)
    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
    End If
    Next Tc
If X(Tr, 1) > 0 Then Tr = Tr - 1
Next Tr
Range("B3:H4") = D: Range("J3:J4") = X
End Sub

 

[kvsrinivasamurthy]

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

 

[edge37]

I see what you are trying to achieve, but which students get the extra point, as there are 7 students and only 5 points ??

In the example, there are 2 students and each have 5 and 3 extra points respectively

 

[edge37]

Why wouldn't all 5 of John's extra points go to HW6? Seems that would be best for John.

That would be even better, if a code can determine that case

 

[edge37]

I see what you are trying to achieve, but which students get the extra point, as there are 7 students and only 5 points ??

In the example, there are 2 students and each have

See if this does what you want. Test with a copy of your worksheet.

Sub Distribute_Extras()
  Dim p As Variant, Maxp As Variant, x As Variant
  Dim i As Long, j As Long, ubp2 As Long
 
  With Range("B3", Range("B3").End(xlToRight)).Resize(Range("A" & Rows.Count).End(xlUp).Row - 2)
    p = .Value
    ubp2 = UBound(p, 2)
    Maxp = .Rows(0).Value
    For j = 1 To ubp2
      Maxp(1, j) = Val(Split(Maxp(1, j))(0))
    Next j
    x = .Offset(, .Columns.Count + 1).Resize(, 1).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
    .Offset(, .Columns.Count + 1).Resize(, 1).Value = x
  End With
End Sub

Here is my sheet after the code has been run

edge37.xlsm
	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	7	5	5	4	6	0	8		0
4	Mary	7	5	5	1	6	7	8		0
5
Sheet1

Fantastic coding Peter, I'm almost there. I want to ask you if you could please see if your code can be modified for the following:

1) I'm including my basic gradebook with sample names and grades with the exact ranges of where any homeworks are going to be (C9:K38), in the image I have HW from C9:J33, but sometimes I could have only 5 HWs or 9 HWs in other periods, also the number of students vary between grades/sections. I need, if possible, if your code could still work defining the whole HW range, eventhough some rows or columns may not be filled with values (I tried your code (in the previous example) and there is a "Runtime error '13': Type mismatch" if I erase Mary's name and grades, or, if I delete HW7 then the code would do nothing. When there are no values in a row or column, the code wouldn't work)

2) Can you please modify your code so it fits directly into my gradebook I am sending you here? Range for all HWs= C9:K38; Range of Maximum Points for each HW: C8:K8; Range of EXTRA POINTS: O9:O38

Thank you very much for all this trouble. I hope I could explain myself here. I appreciate your assistance.

EXAMPLE 2.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
2
3
4
5
6			1	2	3	4	5	6	7	8	9
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	4	5	5	8	7					5
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	3	2	0	5	0	8	0					5
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	0	3	3	5	0	8	0					1
19	11	Mia	0	2	0	2	0	5	8	0					5
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	3	4	4	4	8	7					3
26	18	Henry	5	5	5	5	5	5	8	7					2
27	19	Grace	5	2	2	4	3	3	7	5					5
28	20	William	5	5	5	0	4	5	8	7					4
29	21	Abigail	5	5	5	5	5	5	8	7					3
30	22	Alexander	0	5	5	5	5	5	8	7					2
31	23	Ella	5	0	0	0	5	4	6	3					1
32	24	James	5	5	5	4	5	5	8	7					5
33	25	Chloe	5	4	0	2	5	5	8	6					5
34
35
36
37
38
10A (1)