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
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