i tried calculating the accumulative sum of a cell in a column in the corresponding cell .for example in column H cell 3 i wrote (2) .so column J cell 3 it should hold (2) . and if H3 is changed to (3) .cell J3 to change to (5) and so on to the whole column (H3) (J3),(H4) (J4) and so on . so with that same conscept of holding accumulative sums i tried making ((G H)-I)=J) with each of G and H and I columns is with that same conscept of holding accumulative sums. big thanks to VBasic2008 he helped me with the first code .cause im so new to VBA

here is the code i tried

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearError ' start error-handling routine
    
    ' Define constants.
    Const SRC_FIRST_CELL As String = "E2"
    Const DST_COLUMN As String = "F"
    
    ' Reference the changed cells, the Source range.
    
    Dim srg As Range
    
    With Me.Range(SRC_FIRST_CELL) ' from the first...
        Set srg = .Resize(Me.Rows.Count - .Row   1) ' ... to the bottom cell
    End With
    
    Set srg = Intersect(srg, Target)
    If srg Is Nothing Then Exit Sub ' no changed cells
        
    ' Calculate the offset between the Source and Destination columns.
    Dim cOffset As Long: cOffset = Me.Columns(DST_COLUMN).Column - srg.Column
        
    ' Return the sum of each Source and Dest. cell in the Destination cell.
        
    Application.EnableEvents = False ' to not retrigger this event when writing
    
    Dim sCell As Range, sValue, dValue
    
    For Each sCell In srg.Cells ' current source cell
        With sCell.Offset(, cOffset) ' current destination cell
            sValue = sCell.Value
            dValue = .Value
            If VarType(sValue) = vbDouble Then ' source is a number
                If VarType(dValue) = vbDouble Then ' destination is a number
                    .Value = dValue   sValue
                Else ' destination is not a number
                    .Value = sValue
                End If
            'Else ' source is not a number; do nothing
            End If
        End With
    Next sCell
                   
ProcExit:
    On Error Resume Next ' prevent endless loop if error in the following lines
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
ClearError: ' continue error-handling routine
    Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit
End Sub

CodePudding user response：

A Worksheet Change: Accumulative Sum (Multiple Columns)

Private Enum MathOp
    Add = 1
    Subtract = 2
End Enum

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearError ' start error-handling routine

    ' Define constants.
    Const SRC_FIRST_CELLS As String = "G3,H3,I3"
    Const DST_COLUMN As String = "J"
    Dim dMathOps() As Variant: dMathOps = VBA.Array( _
        MathOp.Add, MathOp.Add, MathOp.Subtract)
    
    ' Add the references of each column's intersection to the 'items',
    ' and the index of each associated math operation to the 'keys'
    ' of a dictionary.
    Dim dict As Object
    Set dict = IntersectionsToDictionary(SRC_FIRST_CELLS, Target)
    If dict Is Nothing Then Exit Sub ' no intersections
    
    Application.EnableEvents = False ' to not retrigger this event when writing
    
    ' Update the Destination cells.
    Dim sKey As Variant
    For Each sKey In dict.Keys
        UpdateDestinationCells dict(sKey), DST_COLUMN, dMathOps(sKey)
    Next sKey
    
ProcExit:
    On Error Resume Next ' prevent endless loop if error in the following lines
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
ClearError: ' continue error-handling routine
    Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit
End Sub

Function IntersectionsToDictionary( _
    ByVal SourceFirstCellAddresses As String, _
    ByVal Target As Range) _
As Object
    
    Dim sfCells As Range
    Set sfCells = Target.Worksheet.Range(SourceFirstCellAddresses)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim srg As Range, sfCell As Range, MathOpIndex As Long
    
    For Each sfCell In sfCells.Cells
        With sfCell ' from the first... to the bottom-most cell...
            Set srg = .Resize(.Worksheet.Rows.Count - .Row   1)
        End With
        Set srg = Intersect(srg, Target)
        If Not srg Is Nothing Then Set dict(MathOpIndex) = srg
        MathOpIndex = MathOpIndex   1
    Next sfCell

    If dict.Count = 0 Then Exit Function ' no intersection; result = 'Nothing'
    
    Set IntersectionsToDictionary = dict
    
End Function

Sub UpdateDestinationCells( _
        ByVal SourceRange As Range, _
        ByVal DestinationColumn As String, _
        ByVal MathOperation As Long)
    
    ' Calculate the offset between the Source and the Destination column.
    Dim ColumnOffset As Long
    With SourceRange
        ColumnOffset = .Worksheet.Columns(DestinationColumn).Column - .Column
    End With
    
    ' Update the Destination cells.
    
    Dim sCell As Range, sValue, dValue
    
    For Each sCell In SourceRange.Cells ' current source cell
        With sCell.Offset(, ColumnOffset) ' current destination cell
            sValue = sCell.Value
            dValue = .Value
            If VarType(sValue) = vbDouble Then ' source is a number
                Select Case MathOperation
                Case MathOp.Add
                    If VarType(dValue) = vbDouble Then ' destination is a number
                        .Value = dValue   sValue
                    Else ' destination is not a number
                        .Value = sValue
                    End If
                Case MathOp.Subtract
                    If VarType(dValue) = vbDouble Then ' destination is a number
                        .Value = dValue - sValue
                    Else ' destination is not a number
                        .Value = -sValue
                    End If
                End Select
            'Else ' source is not a number; do nothing
            End If
        End With
    Next sCell

End Sub