I have a project where data needs to be imported and assigned to groups. Each data member must have a value, but sometimes I get data where only the group has a value to represent all of the members. If you had to fix this problem with a calculator, you would take the group total and divide it by the number of group members to get a value to use for each group member. The kicker is the value for each member must be a whole number, so if th e group total divided by group members has a remainder, you would have to do some rounding to get a whole number for the last member in the group.

This is a VBA Macro that I wrote to perform this math. With a range selected, it will test the division to see whether the values are a multiple of the group total, and if so, apply them, otherwise, it will use some extra logic to assign the rounded value to the n-1 cells in the group and then assign the remainder to the last cell.

Sub DistSplit()

'

' DistSplit Macro

' Split Distribution Evenly across selected cells

Dim oRange As Range

Set oRange = Selection

Dim oWS As Worksheet: Set oWS = oRange.Worksheet

If oRange.Columns.Count > 1 Then

MsgBox ("You must only select cells in a single column")

Exit Sub

End If

Dim iCol As Integer: iCol = oRange.Column

Dim iFirstRow As Integer: iFirstRow = oRange.Row

Dim iLastRow As Integer: iLastRow = iFirstRow + (oRange.Rows.Count - 1)

Dim sSplitValue As String: sSplitValue = oWS.Cells(iLastRow, iCol).Value

Dim iSplitValue As Integer: iSplitValue = 0

If IsNumeric(sSplitValue) Then

iSplitValue = sSplitValue

Else

MsgBox ("The last cell in the range must contain the value to split evenly, and must be numeric")

Exit Sub

End If

Dim iRowsToAffect As Integer: iRowsToAffect = oRange.Rows.Count - 1

Dim iSplit As Integer: iSplit = 0

Dim iRow As Integer

'-- Branch to check for even division or hanging chad math

If (iSplitValue Mod iRowsToAffect = 0) Then

iSplit = iSplitValue / iRowsToAffect

For iRow = (iLastRow - (oRange.Rows.Count - 1)) To iLastRow - 1

oWS.Cells(iRow, iCol).Value = iSplit

Next

Else

Dim dSplit As Double: dSplit = iSplitValue / iRowsToAffect

iSplit = Math.Round(dSplit, 0)

For iRow = (iLastRow - (oRange.Rows.Count - 1)) To iLastRow - 2

oWS.Cells(iRow, iCol).Value = iSplit

Next

'-- Now, apply the remainder to the last cell in the range

Dim iUsed As Integer: iUsed = (iSplit * (oRange.Rows.Count - 2))

Dim iLeft As Integer: iLeft = (iSplitValue - iUsed)

oWS.Cells(iLastRow - 1, iCol).Value = iLeft

End If

End Sub

Add comment

biuquotesnippet