Excel VBA code question [Solved/Closed]

Report
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hi.

I have few numbers that sum up to 100 (percentage). When a user change one of the numbers the sum changed. lets call this sum value "S". I need a macro to change the values of the rest of the nubers (proportionally) in order that the sum "S" will be 100 again.

To do that, each one of the values needs to be divided by "S" and multiply by 100. I wrote following macro code for excel. It "almost" working: I need to divide each number by the intial sum"S" but it dividing each number by the most updated Sum each time.

Please help me to correct this macro. Thanks!

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

3 replies

The user will change this value in the excel spreadsheet.
The reset of the other numbers will occur when the user run the macro. The macro code outline in my post.
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
Then you have this issue that how would macro know which cell was changed and which needs to be readjusted. There might be other ways too, but only way I can think of required that this readjustment happens on its on as soon as the value is changed
Yes - this readjustment can happen on its on as soon as the value is changed. What is the code for this?
Thanks.
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
You have to use two events

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

End Sub


The Worksheet_SelectionChange event is triggered when a cell is clicked. So as soon as it is clicked you store that value


The Worksheet_Change event is then triggered if a cell value is change manually
and there you will adjust the numbers

Could you please upload a sample file with sample data etc on some shared site like https://authentification.site and post back here the link
sample file was uploaded as requested:
https://authentification.site/files/22317946/sample_percentage_.xls

I will appreciate the vba code. Thanks.
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
Who would be changing this value ? Does this reset of numbers has be occur by its own ?

Could you please upload a sample file with sample data etc on some shared site like https://authentification.site and post back here the link to allow better understanding of how it is now and how you foresee.
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
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

Thanks. It works fine, however the calculation math need to be change - the code above add equal value to each cell. However, I need the cells to change proportionally to their values using the following math:
For example, if the first excel cell is changed by user from 10 to 20:

20
30
20
40
110

The automatic result by code will be:

20
30/(110-20)*(100-20)=26.67
20/(110-20)*(100-20)=17.77
40/(110-20)*(100-20)=35.55
100

Please post code reflecting the math above. Thanks.
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
You just need to change this line to fit your requirement

Cells(lFixRow, Target.Column) = Cells(lFixRow, Target.Column) + (vLastDiff / (lEndRow - lStartRow))