Subtracting with vba until a total is reached

[BalloutMoe]

Hello All,
I need some help with my code if possible or making it a function but I am having issues. I have Cell A3 with a certain Value say 600, I would like to loop through all the cells in Column D to Last Row and subtract from each cell but do not exceed cell value to be 7.
So InitialSubtracted = 600 and loop until it reaches total subtracted to be 600. With the below code however sometimes its going above 600 and its entering an endless loop. Any help would be appreciated for a way around this as I am stuck. The initial subtracted varies but its always 100 increments. So 300,400, 500,600 and so on. Below is the code I have.

$141.30​

$89.79​

$81.66​

77.33​

$77.33​

$73.00​

$70.32​

$69.21​

50.84​

$40.00​

$40.00​

$25.50​

For example this is a total of 836.28 and I need the new total to be 236.28

Sub SubtractFromRange()

lastR = ThisWorkbook.Worksheets("Sheet2").Range("B" & ThisWorkbook.Worksheets("Sheet2").Rows.Count).End(xlUp).Row
InitialSubtracted = 0
Do
For i = 2 To lastR
 
        If ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value >= 107 And ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value <= 2000 Then
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 100
        ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value = ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 100
        InitialSubtracted = InitialSubtracted + 100
        Debug.Print InitialSubtracted
        End If

        If ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value >= 57 And ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value <= 106.99 Then
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 50
        ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value = ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 50
        InitialSubtracted = InitialSubtracted + 50
        Debug.Print InitialSubtracted
        End If
              
        If ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value >= 32 And ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value <= 56.99 Then
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 25
        ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value = ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 25
        InitialSubtracted = InitialSubtracted + 25
        Debug.Print InitialSubtracted
        End If
      
        If ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value >= 17 And ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value <= 31.99 Then
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 10
        ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value = ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 10
        InitialSubtracted = InitialSubtracted + 10
        Debug.Print InitialSubtracted
        End If
      
        If ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value >= 12 And ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value <= 16.99 Then
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value
        Debug.Print ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 5
        ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value = ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value - 5
        InitialSubtracted = InitialSubtracted + 5
        Debug.Print InitialSubtracted
        End If
      
        If InitialSubtracted = ThisWorkbook.Worksheets("Sheet2").Range("A3").Value Then
        MsgBox ("We took out " & ThisWorkbook.Worksheets("Sheet2").Range("A3").Value)
        Exit Sub
        End If
  
Next
Loop Until InitialSubtracted = ThisWorkbook.Worksheets("Sheet2").Range("A3").Value
End Sub

 

[bebo021999]

In your code, there are rules:
If column D:
>=107: subtract 100
>=57: subtract 50
>=32: subtract 25
>=17: subtract 10
>=12: subtract 5

So: D2=141.3 - 100 = 41.3
D3= 89.79 - 50 = 39.79

Is subtract "100,50,25,10,5" stricky, or any value?
is it possible:
D2=141.3 - 134.3 = 7
D3 = 89.79 - 82.79 = 7
initialSubtracted = 134.3 + 82.79 = 217.09
D4=...
untill initialSubtracted = 600 is reached?

 

[BalloutMoe]

In your code, there are rules:
If column D:
>=107: subtract 100
>=57: subtract 50
>=32: subtract 25
>=17: subtract 10
>=12: subtract 5

So: D2=141.3 - 100 = 41.3
D3= 89.79 - 50 = 39.79

Is subtract "100,50,25,10,5" stricky, or any value?
is it possible:
D2=141.3 - 134.3 = 7
D3 = 89.79 - 82.79 = 7
initialSubtracted = 134.3 + 82.79 = 217.09
D4=...
untill initialSubtracted = 600 is reached?

I would rather keep it strictly 100, 50,25,10,5.

 

[BalloutMoe]

or maybe 10,20 but I would want to subtract from the biggest numbers first if possible

 

[BalloutMoe]

The code I have was working but when it keeps going above 600 so I am stuck on how to fix it or limit it

 

[bebo021999]

Try

Option Explicit
Sub test()
Dim lr&, i&, k&, iSub&, cell As Range, ary, arr()
Worksheets("Sheet2").Activate
ary = Array(100, 50, 25, 10, 5, 0.1)
lr = Cells(Rows.Count, "D").End(xlUp).Row
ReDim arr(1 To lr - 1, 1 To 1)
    Do While iSub < Range("A3").Value
        k = k + 1
        Set cell = Range("D2").Offset(k - 1, 0) 'start cell = D2
        For i = 0 To UBound(ary)
            If cell - ary(i) > 7 Then
                iSub = iSub + ary(i) ' running sum of subtraction
                If iSub <= Range("A3").Value Then
                    arr(k, 1) = cell - ary(i)
                Else
                    arr(k, 1) = Range("A3").Value - iSub ' last remaining
                End If
                Exit For
            End If
        Next
    Loop
MsgBox ("We took out " & Range("A3").Value)
Range("D2").Resize(k, 1).Value = arr
End Sub