Edit numbers until sum value has reached - excel

Question

I wish to have a VBA macro that will help me to edit values in the column 'C' for each row until the sum value has reached.
However, there are some criteria:
The value has to be smaller than the value in column 'B'
If the value in column 'B' is zero, then the value in column 'C' should be zero
For example:
I have certain values in column A for each row and I want the sum for Column C to be 10. Hence, the VBA will loop and iterate each row in column C and check if the number in Column B is greater than 0, if yes then it will add 1 to it. After going through each row, it will check the sum, if the sum has not reach the certain amount (in this case, it's 10), it will loop back again and add 1 to each row and stop when it reaches the sum.
Example output:
----------------------
Column B | Column C
----------------------
124 | 3
100 | 3
83 | 2
23 | 1
4 | 1
0 | 0
-----------------------
Code:
Sub Loop()
Dim Report As Worksheet
Set Report = Excel.ActiveSheet
Dim cell As Range
Dim i As Integer
Dim total As Integer
total = Range("C8").Value
Range("C2:C7").ClearContents
For total = 0 To 10
For Each cell In Range("C2:C12")
For i = 2 To 7
If Range("B" & i).Value > 0 Then
cell.Value = cell.Value + 1
If cell.Value > Range("B" & i).Value Then
cell.Value = cell.Value
End If
Else:
cell.Value = 0
End If
Next i
Next cell
total = total + Range("C8").Value
Next total
End Sub
However, the output that I got seems to be not my desire output and I got all zeros instead. I am a newbie to VBA :(, can anyone help me with this?

Answer 1

Below is my take on your problem but a couple of things to start...
VBA didn't much like the sub having the name loop as loop is a reserved word
I've used methods intersect and offset when working with ranges but there are multiple ways to skin this cat
Range("C2:C7").ClearContents will result in empty cells and while an empty cell will likely be considered 0 when trying to add 1 to the value, it would perhaps be better to give the cells an explicit value e.g. 0
There exists some cases where a total of, for example, 10 can't be reached and if not tested for and handled, the loop will run forever, never reaching 10
I'm not sure if msgbox is appropriate to your task but I popped it in anyway in case you haven't yet come across it
Sub SomeLoop()
Set totalCell = Range("C8")
Set editableColumnRange = Range("C2:C7")
'set all the editable cells to a default/initial value
editableColumnRange.Value = 0
totalAtEndOfLastLoop = 0
total = 0
Offset = 0
Do While total < 10
'set the current row to the current row offset past the top row of the editable cells
Set currentRowRange = editableColumnRange.Rows(1).EntireRow.Offset(Offset)
Set currentCCell = Intersect(currentRowRange, Range("C:C"))
Set currentBCell = Intersect(currentRowRange, Range("B:B"))
'implement the rules
If currentBCell.Value = 0 Then
currentCCell.Value = 0
ElseIf currentBCell.Value > currentCCell.Value + 1 Then
'to ensure b remains > c, we need to test b > c + 1
'so if c is incremented by 1, it remains less than b
currentCCell.Value = currentCCell.Value + 1
total = total + 1
End If
Offset = Offset + 1
If Offset >= editableColumnRange.Rows.Count Then
'we've got an offset which would task us past the data
'it's time to wrap around
'check if the total has changed otherwise we'll be stuck in the loop forever
If total > totalAtEndOfLastLoop Then
totalAtEndOfLastLoop = total
Offset = 0
Else
MsgBox "The total hasn't changed"
Exit Do
End If
End If
Loop
End Sub

Answer 2

Increment While Less Than
Adjust the values in the constants section and the worksheets (possibly workbooks).
Option Explicit
Sub doIncrement()
' Constants
Const sFirst As String = "B2"
Const dFirst As String = "C2"
Const iTotal As Long = 10
' Worksheets (could be different)
Dim sws As Worksheet: Set sws = ActiveSheet
Dim dws As Worksheet: Set dws = ActiveSheet
' Create a reference to the Source Range.
Dim srg As Range
With sws.Range(sFirst)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
Set srg = .Resize(lCell.Row - .Row + 1)
End With
' Write values from Source Range to Source Array.
Dim rCount As Long: rCount = srg.Rows.Count
Dim sData As Variant
If rCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData = srg.Value
Else
sData = srg.Value
End If
' Define Destination Array.
Dim dData() As Long: ReDim dData(1 To rCount, 1 To 1) ' Long: all zeros
Dim r As Long
Dim dTotal As Long
' Loop through rows of Source Array and write to rows of Destination Array.
Do
For r = 1 To rCount
If sData(r, 1) - dData(r, 1) > 1 Then
dData(r, 1) = dData(r, 1) + 1
dTotal = dTotal + 1
If dTotal = iTotal Then
Exit Do
End If
End If
Next r
Loop
With dws.Range(dFirst)
' Write values from Destination Array to Destination Range.
.Resize(rCount).Value = dData
' Clear contents below.
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
End With
End Sub