'中间觉得用二分匹配比用纯循环效率高得多
'如果A、B列日期数据有交叉或有包含的会跟用前面的方法得到的结果有所不同,否则结果应该相同
'有空帮我测试比较一下效率,包括准确性,,,
Option Explicit
Sub test()
Dim arr, brr, dic(1), i As Long, j As Long, s As String
Dim left As Long, right As Long, mid As Long
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = [a1].CurrentRegion.Offset(1).Resize(, 7).Value
For i = 1 To UBound(arr, 1) - 1
arr(i, 7) = arr(i, 3) & arr(i, 4)
Next
Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 7)
For i = 1 To UBound(arr, 1) - 1
If arr(i, 7) <> arr(i + 1, 7) Then
Call qsort(arr, j + 1, i, 1, UBound(arr, 2), 1)
dic(0)(arr(i, 7)) = j + 1: dic(1)(arr(i, 7)) = i - j: j = i
End If
Next
brr = [h1].CurrentRegion.Offset(1).Resize(, 6).Value
For i = 1 To UBound(arr, 1) - 1
s = brr(i, 2) & brr(i, 3)
If dic(0).exists(s) Then
left = dic(0)(s): right = dic(0)(s) + dic(1)(s) - 1
mid = (left + right) / 2
Do While left <= right
If brr(i, 1) >= arr(mid, 1) And brr(i, 1) <= arr(mid, 2) Then
brr(i, 5) = arr(mid, 5): brr(i, 6) = arr(mid, 6) * brr(i, 4)
Exit Do
ElseIf brr(i, 1) < arr(mid, 1) Then
right = mid - 1
Else
left = mid + 1
End If
mid = (left + right) / 2
Loop
If left > right Then brr(i, 5) = vbNullString: brr(i, 6) = brr(i, 5)
Else
brr(i, 5) = vbNullString: brr(i, 6) = brr(i, 5)
End If
Next
[h2].Resize(UBound(brr, 1) - 1, UBound(brr, 2)) = brr
End Sub
Sub qsort(arr, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, x As String, t
i = first: j = last: x = arr((first + last) / 2, key)
While i <= j
While StrComp(arr(i, key), x, vbTextCompare) = -1: i = i + 1: Wend
While StrComp(x, arr(j, key), vbTextCompare) = -1: j = j - 1: Wend
If i <= j Then
For k = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
i = i + 1: j = j - 1
End If
Wend
If first < j Then qsort arr, first, j, left, right, key
If i < last Then qsort arr, i, last, left, right, key
End Sub |