Apportioning values

Cranberries

New Member
Joined
Oct 11, 2006
Messages
5
Hi

I'm trying to apportion the below '111111' accounts
In other words each of the 2 calc figues has to be apportioned to the '111111' account and the new figures are derived in the NewCalc 1 and New Calc 2 columns
I have hundreds of lines to apportion so if there is an easier way with VBA to calculate colums E to H please let me know.
Any help would be greatly appreciated!
Testing2.xls
ABCDEFGH
1Calc1Calc2Current%New%NewCalc1NewCalc2
2AAA11111150,128,793.4918,937,000.00
3AAA5678922,821,685,961.843,517,685,034.7384.07%86.70%2,863,828,579.983,534,103,778.51
4AAA567892534,719,480.32539,531,667.9015.93%13.30%542,705,655.67542,049,924.12
5BBB1111111,141,648,765.21525,914,150.38
6BBB512335711,696,607.43539,016,600.3728.50%25.46%1,037,074,947.99672,904,836.88
7BBB3578921,660,573,766.391,489,784,915.8666.50%70.36%2,419,766,280.221,859,837,851.21
8BBB357892111,331,098.7474,570,732.004.46%3.52%162,230,214.7293,093,619.41
9BBB35789250,527.8339,701.970.00%0.00%73,628.4949,563.68
10BBB35789213,464,284.8913,849,915.420.54%0.65%19,619,979.0817,290,144.81
11CCC111111219,783,139.60169,499,988.79
12CCC3001411,367,444,586.651,824,679,907.7599.33%0.991,585,745,829.471,992,830,965.02
13CCC4501219,282,639.4714,637,839.770.67%0.0110,764,536.2515,986,771.29
14DDD11111151,050,214.1237,876,527.24
15DDD5423453,129,876.273,629,025.860.2%0.3%3,245,569.853,725,309.79
16DDD5423471,376,960,513.441,422,766,823.5499.7%99.7%1,427,858,847.061,460,515,129.00
17DDD54234378,011.1382,445.150.0%0.0%80,894.7584,632.55
18DDD442345190,333.76199,511.680.0%0.0%197,369.31204,805.05
19DDD342345710,625.64921,809.050.1%0.1%736,893.40946,266.14
Data Final
 

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Andrew Fergus

MrExcel MVP
Joined
Sep 9, 2004
Messages
5,432
Hi

The following VBA code will do what you want :

Code:
Option Explicit

Public Sub ApportionValues()

Dim OuterLoop As Double, InnerLoop As Double
Dim Loop1Limit As Double, Loop2Limit As Double
Dim tmpValues(6) As Double

'tmpValues :
'  1 = Calc1 value to apportion
'  2 = Calc2 value to apportion
'  3 = Calc1 apportionment divisor
'  4 = Calc2 apportionment divisor
'  5 = Calc1 apportioned so far
'  6 = Calc2 apportioned so far

'Find the last row
Loop1Limit = Range("A2").End(xlDown).Row

If Loop1Limit < 3 Or Loop1Limit >= 65536 Then
'There is no data
    MsgBox "There is no data.", vbCritical, "Error"
    Exit Sub
End If

'Clear the target area
Range("E2:H" & Loop1Limit).ClearContents

'Loop through all records
For OuterLoop = 2 To Loop1Limit
    'Get the values to apportion
    tmpValues(1) = Range("C" & OuterLoop).Value
    tmpValues(2) = Range("D" & OuterLoop).Value
    'Reset the other temp variable values
    tmpValues(3) = 0
    tmpValues(4) = 0
    tmpValues(5) = 0
    tmpValues(6) = 0
    'Find the next row with "111111" or the last row
    'and calculate the divisor
    For InnerLoop = OuterLoop + 1 To Loop1Limit
        If Range("B" & InnerLoop).Value = "111111" Then
            Loop2Limit = InnerLoop - 1
            InnerLoop = Loop1Limit
        ElseIf InnerLoop = Loop1Limit Then
            tmpValues(3) = tmpValues(3) + Range("C" & InnerLoop).Value
            tmpValues(4) = tmpValues(4) + Range("D" & InnerLoop).Value
            Loop2Limit = Loop1Limit
        Else
            tmpValues(3) = tmpValues(3) + Range("C" & InnerLoop).Value
            tmpValues(4) = tmpValues(4) + Range("D" & InnerLoop).Value
        End If
    Next
    'Loop through the records and apportion the values
    For InnerLoop = OuterLoop + 1 To Loop2Limit
        'Show the percentages
        Range("E" & InnerLoop).Value = Range("C" & InnerLoop) / tmpValues(3)
        Range("F" & InnerLoop).Value = Range("D" & InnerLoop) / tmpValues(4)
        If InnerLoop = Loop2Limit Then
            'Set the last row to the amount unallocated (handles rounding errors)
            Range("G" & InnerLoop).Value = Range("C" & InnerLoop) + tmpValues(1) - tmpValues(5)
            Range("H" & InnerLoop).Value = Range("D" & InnerLoop) + tmpValues(2) - tmpValues(6)
        Else
            'Set the values
            Range("G" & InnerLoop).Value = Range("C" & InnerLoop) + Round(tmpValues(1) * (Range("C" & InnerLoop) / tmpValues(3)), 2)
            Range("H" & InnerLoop).Value = Range("D" & InnerLoop) + Round(tmpValues(2) * (Range("D" & InnerLoop) / tmpValues(4)), 2)
            tmpValues(5) = tmpValues(5) + Round(tmpValues(1) * (Range("C" & InnerLoop) / tmpValues(3)), 2)
            tmpValues(6) = tmpValues(6) + Round(tmpValues(2) * (Range("D" & InnerLoop) / tmpValues(4)), 2)
        End If
    Next
    'Jump to the last record processed
    OuterLoop = Loop2Limit
Next

'Format the output area
Range("E3:F" & Loop1Limit).NumberFormat = "#0.00%"
Range("G3:H" & Loop1Limit).NumberFormat = "#,##0.00"

MsgBox "Finished apportioning values", vbInformation, "Done"

End Sub

Just ask if you aren't sure how to use it.

HTH, Andrew
 

Watch MrExcel Video

Forum statistics

Threads
1,114,676
Messages
5,549,371
Members
410,911
Latest member
AniEx
Top