|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub TEST3()
Dim ar, br, cr, i&, j&, r&, n&, t#
Application.ScreenUpdating = False
t = Timer
ar = [A1].CurrentRegion.Value
br = [G1].CurrentRegion.Value
For i = 2 To UBound(br)
ReDim cr(1 To UBound(ar), 1 To 1)
r = 0: br(i, 3) = Empty
For j = 2 To UBound(ar)
If ar(j, 1) = br(i, 1) Then
r = r + 1
cr(r, 1) = ar(j, 2)
End If
Next j
If r Then
ShellSort2D cr, 1, r, 1, 1, 1, False
If r > br(i, 2) Then n = br(i, 2) Else n = r
For j = 1 To n
br(i, 3) = br(i, 3) + cr(j, 1)
Next j
End If
Next i
[G1].Resize(UBound(br), UBound(br, 2)) = br
Application.ScreenUpdating = True
MsgBox "执行完毕!_用时: " & Format(Timer - t, "0.00") & " 秒", 64
End Sub
Function ShellSort2D(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)
Dim iRowSize&, vTemp, interval&, i&, j&, k&
ReDim vTemp(iLeft To iRight)
iRowSize = iLast - iFirst + 1
interval = 1
If iRowSize > 13 Then
Do While interval < iRowSize
interval = interval * 3 + 1
Loop
interval = interval \ 9
End If
Do While interval
For i = iFirst + interval To iLast
For j = iLeft To iRight
vTemp(j) = ar(i, j)
Next
If isOrder Then
For k = i - interval To iFirst Step -interval
If ar(k, iKey) <= vTemp(iKey) Then Exit For
For j = iLeft To iRight
ar(k + interval, j) = ar(k, j)
Next j
Next k
Else
For k = i - interval To iFirst Step -interval
If ar(k, iKey) > vTemp(iKey) Then Exit For
For j = iLeft To iRight
ar(k + interval, j) = ar(k, j)
Next j
Next k
End If
For j = iLeft To iRight
ar(k + interval, j) = vTemp(j)
Next
Next i
interval = interval \ 3
Loop
End Function
|
评分
-
1
查看全部评分
-
|