- Sub Macro1()
- Dim arr, brr, crr, drr, d, d2, d3, i&, j&
- Set d = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- Set d3 = CreateObject("scripting.dictionary")
- arr = Range("a1").CurrentRegion
- brr = Range("h1").CurrentRegion
- ReDim crr(1 To 2000, 1 To 4)
- ReDim drr(1 To UBound(arr), 1 To 1)
- For i = 2 To UBound(brr)
- zf = brr(i, 1) & "," & brr(i, 3)
- If Not d2.exists(zf) Then d2(zf) = brr(i, 4)
- If Not d.exists(brr(i, 1)) Then
- s = s + 1
- d(brr(i, 1)) = s
- crr(s, 1) = brr(i, 3)
- crr(s, 2) = brr(i, 3)
- crr(s, 3) = i
- crr(s, 4) = i
- Else
- n = d(brr(i, 1))
- If brr(i, 3) < crr(n, 1) Then crr(n, 1) = brr(i, 3): crr(n, 3) = i
- If brr(i, 3) > crr(n, 2) Then crr(n, 2) = brr(i, 3): crr(n, 4) = i
- End If
- Next
- For i = 2 To UBound(arr)
- n = d(arr(i, 1))
- If arr(i, 3) > crr(n, 1) Then
- For j = crr(n, 3) To crr(n, 4)
- sz = arr(i, 3) - brr(j, 3)
- If sz > 0 And Not d3.exists(sz) Then d3(sz) = j
- Next
- drr(i, 1) = brr(d3(Application.Min(d3.keys)), 4)
- d3.RemoveAll
- End If
- zf = arr(i, 1) & "," & arr(i, 3)
- If d2.exists(zf) Then drr(i, 1) = d2(zf)
- If arr(i, 3) > crr(n, 2) Or arr(i, 3) < crr(n, 1) Then drr(i, 1) = brr(crr(n, 3), 4)
- Next
- Range("f1").Resize(UBound(drr)) = drr
- End Sub
复制代码 |