|
|
我的思维都有点定位了，碰到这样的问题就想用数组处理，所以代码显得很复杂，但绝对效率高！
qJ8Q8QCC.rar
(14.17 KB, 下载次数: 36)
附代码：
Private Sub CommandButton1_Click() '代码用了数组+dictionary，还加上排序
Dim arr, Xarr()
Dim i%, irow%, iMax%
Dim ds
irow = [b5].End(xlDown).Row
arr = Range("b5:e" & irow)
iMax = UBound(arr)
Set ds = CreateObject("scripting.dictionary")
m = 1
On Error Resume Next
For i = 1 To iMax
ds.Add arr(i, 1), m
If Err.Number = 0 Then
ReDim Preserve Xarr(1 To 2, 1 To m)
Xarr(1, m) = arr(i, 1)
Xarr(2, m) = arr(i, 4)
m = m + 1
Else
s = ds(arr(i, 1))
Xarr(2, s) = Xarr(2, s) + arr(i, 4)
End If
Err.Clear
Next
On Error GoTo 0
iMax = m - 1
For i = 1 To iMax - 1 '冒泡排序,按数量降序
For j = i + 1 To iMax
If Xarr(2, i) < Xarr(2, j) Then
t1 = Xarr(1, j)
t2 = Xarr(2, j)
Xarr(1, j) = Xarr(1, i)
Xarr(2, j) = Xarr(2, i)
Xarr(1, i) = t1
Xarr(2, i) = t2
End If
Next
Next
With Sheet8
.Range("a6:b16").ClearContents
.[a6].Resize(iMax, 2) = Application.WorksheetFunction.Transpose(Xarr)
.Select
End With
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-12-22 15:12
楼主