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.

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


1 reply

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

0