MS Excel Macro: Splitting Number evenly across cells

by Misty Rae McKinley 1. July 2009 19:45

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
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
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
'-- 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

  Country flag
  • Comment
  • Preview

Powered by BlogEngine.NET