Sub AwTest()
Dim i&, k%, x&, r&, ValNum, BcSr$, arr, tAr, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = [B1].CurrentRegion
ReDim brr(1 To UBound(arr) * 20, 1 To 3)
For i = 2 To UBound(arr)
tAr = Split(arr(i, 2), ",")
ValNum = arr(i, 4) / (UBound(tAr) + 1)
For k = 0 To UBound(tAr)
BcSr = arr(i, 1) & tAr(k)
x = d(BcSr)
If x = 0 Then r = r + 1: x = r: d(BcSr) = x: brr(r, 1) = BcSr
brr(x, 2) = IIf(brr(x, 2) > CDate(arr(i, 3)), brr(x, 2), CDate(arr(i, 3)))
brr(x, 3) = brr(x, 3) + ValNum
Next
Next
[K3].Resize(r, 3) = brr
End Sub |