macro to change numbers proportionally to sumClosed

Question

Hello.
I have several numbers that sum up to 100 in excel spreadsheet. When a user changing one of the numbers in the excel worksheet I called the new sum value "S". 
I need a macro to change (proportionally) the values of the rest of the numbers in order that the sum "S" will be 100 again. 

For example:

10
30
20
40
100

If the first excel cell is changed from 10 to 20:

20
30
20
40
110

The macro will change the values as proportionally so that they sum up to 100. This is done by dividing each one of the values needs to be divided by "S" and multiply by 100:

20/110*100=18.18
30/110*100=27.27
20/110*100=18.18
40/110*100=36.37
100


I wrote following macro code for excel. It is just "almost" working: I need to divide each number by the initial sum "S" however it dividing each number by the most updated Sum each time, instead. 

Please help me to correct this macro. Thanks!

Code:
Sub test()
s = "=Sum(D7:D10)"
Range("A1").Value = s
x = 7
Do While Not Range("D11").Value = 100
Cells(x, 4).Value = Cells(x, 4).Value * 100 / Range("A1").Value
x = x + 1
Loop
End Sub 


Configuration: Windows XP / Internet Explorer 8.0

rizvisa1 · Answer

Assumption. 1. The adjustment will be done on all cell except for the one which caused the change 2. Sum formula is below the range on which the sum formula is based upon Steps 1. Press ALT + F11 to open VBE 2. Press CTRL + R to open the project explorer 3. Double click on the sheet 4. Paste the code Private Sub Worksheet_Change(ByVal Target As Range) Dim lSumRow As Long ' row on which sum formula is Dim vFormula As Variant ' sum formula Dim sStartRange As String ' start range of sum formula Dim sEndRange As String ' end range of sum formula Dim lStartRow As Long ' sum start at this row Dim lEndRow As Long 'sum end at this for Dim lFixRow As Long ' row to be fixed Dim vLastDiff As Variant ' difference in current Sum and 100 ' if change did not happen in column D, then exit If Target.Column <> 4 Then Exit Sub On Error GoTo End_Sub Application.EnableEvents = False On Error Resume Next ' find where the sum formula is lSumRow = 0 lSumRow = Range(Target, Cells(Rows.Count, Target.Column)).Find("=Sum(", Target, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Row On Error GoTo End_Sub ' change from 100 vLastDiff = 100 - Cells(lSumRow, Target.Column) ' if difference is blank or zero If ((vLastDiff = "") Or (vLastDiff = 0)) Then GoTo End_Sub 'sum formula vFormula = Cells(lSumRow, Target.Column).Formula ' if there is a sum formula If (vFormula <> "") Then 'get the start range and end range If (InStr(1, vFormula, ":") > 0) Then sStartRange = Left(vFormula, InStr(1, vFormula, ":") - 1) sStartRange = Mid(sStartRange, 6) lStartRow = Range(sStartRange).Row sEndRange = Mid(vFormula, InStr(1, vFormula, ":") + 1) sEndRange = Mid(sEndRange, 1, Len(sEndRange) - 1) lEndRow = Range(sEndRange).Row Else sStartRange = Mid(vFormula, 6) sStartRange = Mid(vFormula, 1, Len(sStartRange) - 1) lStartRow = Range(sStartRange).Row lEndRow = Range(sStartRange).Row End If ' if the row that is changed is included in the sum formula If ((lStartRow <= Target.Row) And (lEndRow >= Target.Row)) Then If (lEndRow - lStartRow > 0) Then For lFixRow = lStartRow To lEndRow If (lFixRow = Target.Row) Then GoTo Next_lFixRow Cells(lFixRow, Target.Column) = Cells(lFixRow, Target.Column) + (vLastDiff / (lEndRow - lStartRow)) Next_lFixRow: Next lFixRow End If End If End If End_Sub: Application.EnableEvents = True End Sub

Macro to change numbers proportionally to sum

1 response

Similar discussions

Subscribe To Our Newsletter!