Addere til celle

Jeg ved ikke om det du ønsker kan lade sig gøre, men her er noget lignende:

Hvis du indtaster tal i A1 akkumuleres de i B1 med følgende kode:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
  Range("B1") = Range("B1") + Target
End If
End Sub

Fandt en gammel løsning!

Private mdValue As Double
Private mdValueTemp As Double
Private msCellAdr As String

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("C9:C23")
    Application.EnableEvents = False
   
    If Not Intersect(Target, rCalcCells) Is Nothing Then
        mdValueTemp = mdValue
        mdValue = 0
        If Selection.Rows.Count = 1 Then
            Target.Value = Target.Value + mdValueTemp
        Else
            Range(msCellAdr).Value = Range(msCellAdr).Value + mdValueTemp
            mdValue = ActiveCell.Value
            msCellAdr = ActiveCell.Address
        End If
    End If
   
    Application.EnableEvents = True
    Set rCalcCells = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("C9:C23")

    If Not Intersect(Target, rCalcCells) Is Nothing Then
        If Selection.Rows.Count = 1 Then
            mdValue = Target.Value
        Else
            mdValue = ActiveCell.Value
            msCellAdr = ActiveCell.Address
        End If
    End If

    Set rCalcCells = Nothing
End Sub