相应单元格中某个单元格的累计和继续

Question

我尝试计算相应单元格中一列中某个单元格的累计和。例如，在 H 列单元格 3 中，我写了 (2) 。因此 J 列单元格 3 应该包含 (2) 。如果 H3 更改为 (3) .cell J3 更改为 (5) 等等整个列 (H3) (J3),(H4) (J4) 等等。因此，对于持有累积和的相同概念，我尝试使用 G 和 H 和 I 列中的每一列制作 ((G+H)-I)=J) 与持有累积和的相同概念。非常感谢 VBasic2008，他帮助我编写了第一个代码。因为我对 VBA 很陌生

这是我试过的代码

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

Answer 1

工作表更改：累计总和（多列）

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