[讨论]有点难度的汇总

tycp

0.046875

0.28125

0.40625

0.75

0.859375

运行已经三重排序后的数据 ,你的只用了0.8秒!

彭希仁

QUOTE:

以下是引用ldy888在2007-12-1 15:19:41的发言：

彭兄的 29000行的 0.56 秒   计算时间 只有 0.18 秒

先创个小记录 先[em02]

高明啊.

tycp

QUOTE:

以下是引用ldy888在2007-12-1 15:19:41的发言：

彭兄的 29000行的 0.56 秒   计算时间 只有 0.18 秒

先创个小记录 先[em02]

先恭喜啊！你的代码在我的机子上是０.４秒多的样子，已经三重排序和打乱数据都是０.４秒，这一点确实比较好，而我的在已经三重排序下，却只有０.６秒，但打乱数据，我的也是０.４秒多的样子，你可以在运行之前先把数据打乱！

Sub luandata()
Dim p As Long, m As Long, i As Long
Dim arr, temp, t, swt
 With Worksheets("数据")
        i = .Range("a65536").End(xlUp).Row
        arr = .Range("a2:c" & i)
    End With
    m = UBound(arr, 1)
For p = 1 To m
temp = Int(Rnd() * m) + 1
For t = 1 To 3
swt = arr(p, t)
arr(p, t) = arr(temp, t)
arr(temp, t) = swt
Next
Next
Worksheets("数据").Range("a2").Resize(m, 3) = arr
End Sub

tycp

本来就应该就是字典最快的!!!这贴也该结了!!

ldy888

QUOTE:

以下是引用tycp在2007-12-1 15:56:51的发言：

先恭喜啊！你的代码在我的机子上是０.４秒多的样子，已经三重排序和打乱数据都是０.４秒，这一点确实比较好，而我的在已经三重排序下，却只有０.６秒，但打乱数据，我的也是０.４秒多的样子，你可以在运行之前先把数据打乱！

奇怪  为什么越乱越快？

tycp 能不能说一下。

tycp

QUOTE:

以下是引用ldy888在2007-12-1 16:33:21的发言：

奇怪  为什么越乱越快？

tycp 能不能说一下。

If data(j).name = jx Then
                over = True
                data(j).sum = data(j).sum + 1
                checkgz j
                Exit For
            End If

   If data1(n, i).name = gz Then
            over1 = True
            data1(n, i).sum = data1(n, i).sum + 1
            checksf n, i
            Exit For
        End If

看以上代码,如果数据已经三重排序的话,那我的程序将会不断的调用checkgz,checksf 函数!

而不三重排序的话,调用这两个函数的次数就非常少,所以要节约很多时间!

顽皮公主

好的帖子可不能沉了啊!

顶,

彭希仁

Sub peng()
    Dim D1 As New Dictionary, D2 As New Dictionary, D3 As New Dictionary
    Dim i As Long
    Dim y As Long
    Dim j As Long
    Dim dh As Long
    Dim d3i As Long

    Application.ScreenUpdating = False
    r = Sheet2.[A65536].End(xlUp).Row - 1
    arr = Sheet2.Cells(2, 1).Resize(r, 5)
    t = Timer
    For i = 1 To r
        jx = arr(i, 2)
        jxgz = jx & arr(i, 3)
        If D2.Exists(jxgz) = False Then

            D1(jx) = D1(jx) & "," & dh

            dh = dh + 1
        End If
        If D3.Exists(jxgz & arr(i, 1)) = False Then
            D2(jxgz) = D2(jxgz) & "," & d3i
            d3i = d3i + 1
        End If
        D3(jxgz & arr(i, 1)) = D3(jxgz & arr(i, 1)) + 1
    Next
    ReDim arr1(1 To D1.Count + D2.Count, 1 To 11)
    arr2 = D2.Keys
    arr3 = D3.Keys
    arr4 = D3.Items
    For Each k In D1
        xx = 0
        ar1 = Split(D1(k), ",")
        Lk = Len(k) + 1
        For i = 1 To UBound(ar1)
            x = 0
            y = y + 1
            ar2 = Split(D2(arr2(ar1(i))), ",")
            lkk = Len(arr2(ar1(i))) + 1
            For j = 1 To UBound(ar2)
                x = x + arr4(ar2(j))
                If arr4(ar2(j)) > arr1(y, 11) Then
                    arr1(y, 11) = arr4(ar2(j))
                    arr1(y, 10) = Mid(arr3(ar2(j)), lkk)
                End If
                If arr1(y, 11) > arr1(y, 9) Then
                    s = arr1(y, 9): arr1(y, 9) = arr1(y, 11): arr1(y, 11) = s
                    s = arr1(y, 8): arr1(y, 8) = arr1(y, 10): arr1(y, 10) = s
                End If
                If arr1(y, 9) > arr1(y, 7) Then
                    s = arr1(y, 7): arr1(y, 7) = arr1(y, 9): arr1(y, 9) = s
                    s = arr1(y, 6): arr1(y, 6) = arr1(y, 8): arr1(y, 8) = s
                End If
            Next j
            arr1(y, 1) = i
            arr1(y, 2) = k
            arr1(y, 3) = Mid(arr2(ar1(i)), Lk)
            arr1(y, 4) = x
            xx = xx + x
        Next i
        y = y + 1
        arr1(y, 1) = i
        arr1(y, 2) = k
        arr1(y, 3) = "合计"
        arr1(y, 4) = xx
    Next
    For i = y To 1 Step -1
        If arr1(i, 3) = "合计" Then x = arr1(i, 4)
        arr1(i, 5) = arr1(i, 4) / x
    Next i
    Sheet3.[a3].Resize(y, 11) = arr1
    MsgBox (Timer - t)
    Application.ScreenUpdating = True
End Sub

根据树形结构原理,用字典做了一个汇总,速度还可以

非常感谢LDY888兄和狼版两位字典高手.都是跟他二位学的.

[此贴子已经被作者于2007-12-3 15:43:57编辑过]

ldy888

[em17]

lj1226189

代码已下！要细细研究！再次感谢彭兄提供如此好的代码！