Sum less than 999

[wrightyrx7]

Hi all,

I have a spreadsheet which I am trying to make more automated as we have to do this calculation once a day.

Column A - Staff Numbers
Column B - Code
Column E - Miles

Each Staff Number can have multiple rows from 1 - 100

If like the below example a Staff Member has lots of miles. They have to be split into batches less than 999.

The default CODE all the rows contain when i run this report is CVX. But for each time the number of miles goes above 999 the codes has to be changed to MIL1, if after splitting these if there is still more than 999 any remaining will go onto MIL2 and so on. (We have never come across one that goes above MIL4 if this helps make the code simpler)

I hope i have explained this enough. Please see image below hopefully it will show what i mean.

SEE EXAMPLE BELOW.

http://i45.tinypic.com/15s6mih.jpg

Any help would be great

Thanks
Chris

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "F" '<<<< change to suit
Dim Lastrow As Long
Dim Startrow As Long
Dim nSum As Double
Dim nCode As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

Startrow = 2
Lastrow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 2 To Lastrow

If nSum + .Cells(i, TEST_COLUMN).Value <= 999 Then

If nCode > 0 Then

.Cells(i, "B").Value = "Mil" & nCode
End If

nSum = nSum + .Cells(i, TEST_COLUMN).Value
Else

nCode = nCode + 1
.Cells(i, "B").Value = "Mil" & nCode
nSum = .Cells(i, TEST_COLUMN).Value
End If
Next i
End With

Application.ScreenUpdating = True
End Sub

[wrightyrx7]

Perfect! Many thanks XLD! :friends:

[wrightyrx7]

Would it be possible at the end for the macro to delete the rows with code CVX on. As these are already on the system

Regards
Chris

[Bob Phillips]

This should do it

Public Sub ProcessData()
Const TEST_COLUMN As String = "F" '<<<< change to suit
Dim Lastrow As Long
Dim Endrow As Long
Dim nSum As Double
Dim nCode As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

Lastrow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 2 To Lastrow

If nSum + .Cells(i, TEST_COLUMN).Value <= 999 Then

If nCode > 0 Then

.Cells(i, "B").Value = "Mil" & nCode
End If

nSum = nSum + .Cells(i, TEST_COLUMN).Value
Else

nCode = nCode + 1
.Cells(i, "B").Value = "Mil" & nCode
nSum = .Cells(i, TEST_COLUMN).Value
End If
Next i

Endrow = .Columns(2).Find("Mil1").Row - 1
.Rows(2).Resize(Endrow - 1).Delete
End With

Application.ScreenUpdating = True
End Sub