# Macro to change numbers proportionally to sum

Closed
Michael - May 7, 2010 at 03:08 AM
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - May 8, 2010 at 01:15 PM
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.

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

rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
May 8, 2010 at 01:15 PM
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

```