MS Excel Macro: Splitting Number evenly across cells

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    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 IfEnd Sub`

Tags:

programming  • Comment
• Preview 