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
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022  May 8, 2010 at 01:15 PM
Related:
 Macro to change numbers proportionally to sum
 Excel Macro to group by column & sum value ✓  Forum  Excel
 Excel macro to group by column and sum value ✓  Forum  Excel
 Run macro on cell change  Guide
 Macro to insert data to changing cells ✓  Forum  Excel
 Macro: Watch a cell and copy if changed ✓  Forum  Excel
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
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
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