Apportioning values

[Cranberries]

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
	A	B	C	D	E	F	G	H
1			Calc1	Calc2	Current%	New%	NewCalc1	NewCalc2
2	AAA	111111	50,128,793.49	18,937,000.00
3	AAA	567892	2,821,685,961.84	3,517,685,034.73	84.07%	86.70%	2,863,828,579.98	3,534,103,778.51
4	AAA	567892	534,719,480.32	539,531,667.90	15.93%	13.30%	542,705,655.67	542,049,924.12
5	BBB	111111	1,141,648,765.21	525,914,150.38
6	BBB	512335	711,696,607.43	539,016,600.37	28.50%	25.46%	1,037,074,947.99	672,904,836.88
7	BBB	357892	1,660,573,766.39	1,489,784,915.86	66.50%	70.36%	2,419,766,280.22	1,859,837,851.21
8	BBB	357892	111,331,098.74	74,570,732.00	4.46%	3.52%	162,230,214.72	93,093,619.41
9	BBB	357892	50,527.83	39,701.97	0.00%	0.00%	73,628.49	49,563.68
10	BBB	357892	13,464,284.89	13,849,915.42	0.54%	0.65%	19,619,979.08	17,290,144.81
11	CCC	111111	219,783,139.60	169,499,988.79
12	CCC	300141	1,367,444,586.65	1,824,679,907.75	99.33%	0.99	1,585,745,829.47	1,992,830,965.02
13	CCC	450121	9,282,639.47	14,637,839.77	0.67%	0.01	10,764,536.25	15,986,771.29
14	DDD	111111	51,050,214.12	37,876,527.24
15	DDD	542345	3,129,876.27	3,629,025.86	0.2%	0.3%	3,245,569.85	3,725,309.79
16	DDD	542347	1,376,960,513.44	1,422,766,823.54	99.7%	99.7%	1,427,858,847.06	1,460,515,129.00
17	DDD	542343	78,011.13	82,445.15	0.0%	0.0%	80,894.75	84,632.55
18	DDD	442345	190,333.76	199,511.68	0.0%	0.0%	197,369.31	204,805.05
19	DDD	342345	710,625.64	921,809.05	0.1%	0.1%	736,893.40	946,266.14
Data Final

 

[Andrew Fergus]

Hi

The following VBA code will do what you want :

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