7,759
社区成员
发帖
与我相关
我的任务
分享
Sub lqxs()
Dim arr, j&, i&, brr, aa, sl, je, zje, ca
Dim d, k, t, tt
Set d = CreateObject("scripting.dictionary")
Sheet1.Activate
[d4:d20].ClearContents
arr = Sheet4.[a1].CurrentRegion
For i = 3 To UBound(arr)
d(arr(i, 2)) = d(arr(i, 2)) & i & ","
Next
k = d.keys: t = d.items
brr = [a1].CurrentRegion
For i = 4 To UBound(brr)
If brr(i, 2) <> "" Then
sl = brr(i, 3)
zje = 0
If d.exists(brr(i, 2)) Then
tt = d(brr(i, 2))
tt = Left(tt, Len(tt) - 1)
aa = Split(tt, ",")
For j = 0 To UBound(aa)
ca = sl - arr(aa(j), 3)
If ca < 0 Then
zje = zje + sl * arr(aa(j), 4)
Exit For
Else
zje = zje + arr(aa(j), 3) * arr(aa(j), 4)
sl = ca
End If
Next
Else
End If
Cells(i, 4) = zje
Else
Exit For
End If
Next
End Sub