Hallo,
in der folgenden Lösung werden die Fahrten-Summierung bereits nach dem Ändern der Tabelleninhalte berechnet:
Option Explicit
Dim bRunningCalc As Boolean
Private Sub CalcSum(Optional ByRef Target As Range)
Dim sh As Worksheet
Dim iRow As Integer, iRowSum As Integer
Dim strStart As String
Dim strTarget As String
Dim iRides As Integer
bRunningCalc = True
Set sh = ActiveSheet 'ThisWorkbook.Sheets("Tabelle2")
If Target Is Nothing Then
For iRow = 2 To sh.UsedRange.Rows.Count
strStart = sh.Cells(iRow, 1)
strTarget = sh.Cells(iRow, 2)
iRides = 0
For iRowSum = 2 To sh.UsedRange.Rows.Count
iRides = iRides + IIf(sh.Cells(iRowSum, 1) = strStart And sh.Cells(iRowSum, 2) = strTarget, Val(sh.Cells(iRowSum, 3)), 0)
Next
sh.Cells(iRow, 4).FormulaR1C1 = iRides
Next
Else
iRow = Target.Row
strStart = sh.Cells(iRow, 1)
strTarget = sh.Cells(iRow, 2)
iRides = 0
For iRowSum = 2 To sh.UsedRange.Rows.Count
iRides = iRides + IIf(sh.Cells(iRowSum, 1) = strStart And sh.Cells(iRowSum, 2) = strTarget, Val(sh.Cells(iRowSum, 3)), 0)
Next
For iRowSum = 2 To sh.UsedRange.Rows.Count
If sh.Cells(iRowSum, 1) = strStart And sh.Cells(iRowSum, 2) = strTarget Then
sh.Cells(iRowSum, 4).FormulaR1C1 = iRides
End If
Next
End If
bRunningCalc = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not bRunningCalc Then
CalcSum Target
End If
End Sub
Sub ReCalcSumAll()
CalcSum
End Sub
VG, BigBen
|