applying code to column instead of single cells-CodePudding

im new to VBA in excel . Ive been searching alot for a code that can hold accumulative sum of single cells .for example is cell E2 i wrote 3, i want cell F2 to hold the value 3,then if E2 is changed to 2 , cell F2 to do the old value which is (3) the new value (2) and show 5

and so on ive used this code

Private Sub Worksheet_Change(ByVal Target As Range)  
    If Target.Address = "$E$2" Then
        Application.EnableEvents = False
        Call Update_Aa
    End If
     If Target.Address = "$E$3" Then
        Application.EnableEvents = False
        Call Update_Ab
    End If
End Sub

Sub Update_Aa()

Dim Aa As Long
Dim Ba As Long

Aa = Range("E2").Value
Ba = Range("F2").Value

Aa = Aa   Ba
Range("F2").Value = Aa
Application.EnableEvents = True
End Sub
Sub Update_Ab()

Dim Ab As Long
Dim Bb As Long

Ab = Range("E3").Value
Bb = Range("F3").Value

Ab = Ab   Bb
Range("F3").Value = Ab
Application.EnableEvents = True
End Sub

but now i want to apply it to each cell in the column of ("E") and its corresponding cell in ("f"). is there a way instead of writing a sub to each cell?

CodePudding user response：

A Worksheet Change: Accumulative Sum

Compact

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

The Method in a Separate Sub

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
        
    ' 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
    UpdateCells srg, cOffset
    
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

The Method

Sub UpdateCells( _
        ByVal SourceRange As Range, _
        ByVal DestinationColumnOffset As Long)
    
    Dim sCell As Range, sValue, dValue
    
    For Each sCell In SourceRange.Cells ' current source cell
        With sCell.Offset(, DestinationColumnOffset) ' 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

End Sub