Previous Topic Next Topic

Excel VBA code question

Solved/Closed
Michael - May 6, 2010 at 03:22 AM
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - May 8, 2010 at 02:29 PM
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 responses

Answer 1 / 3
Michael
May 6, 2010 at 11:12 PM
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
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
May 7, 2010 at 09:24 AM
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
0
Michael
May 7, 2010 at 10:05 AM
Yes - this readjustment can happen on its on as soon as the value is changed. What is the code for this?
Thanks.
0
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
May 7, 2010 at 10:20 AM
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
0
Michael
May 7, 2010 at 10:51 AM
sample file was uploaded as requested:
https://authentification.site/files/22317946/sample_percentage_.xls

I will appreciate the vba code. Thanks.
0
Answer 2 / 3
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
May 6, 2010 at 04:01 PM
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.
0
Answer 3 / 3
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
May 8, 2010 at 01:18 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
Michael
May 8, 2010 at 02:19 PM
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.
0
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
May 8, 2010 at 02:29 PM
You just need to change this line to fit your requirement

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

Similar discussions

Unlock code
Priya -
HelpiOS -

1 response
lava hard reset & factory reset
AVAY -
Pnr -

2 responses
Tetris unlock the code samsung
Mohit -
HelpiOS -

1 response