[讨论]有点难度的汇总

彭希仁

QUOTE:

以下是引用tycp在2007-11-30 21:23:40的发言：

行的通啊,我的就是用数组构造的类似的树形结构库,当然,用字典构造的话,,速度更快!

砖我抛出来了,接下来就看如何引出LDY888兄的飞快代码了.我对LDY888兄非常有信心

[此贴子已经被作者于2007-11-30 21:50:11编辑过]

ldy888

QUOTE:

以下是引用彭希仁在2007-11-30 21:48:35的发言：

砖我抛出来了,接下来就看如何引出LDY888兄的飞快代码了.我对LDY888兄非常有信心

先汗一个。

QUOTE:

以下是引用tycp在2007-11-30 20:19:26的发言：

改为动态大小不太好吧,因为事先并不知道里面有多少机型,多少故障,多少省份,不可能为了得到这些数据先去循环一次,那样浪费时间了!

Dim data(1 To 50) As tjx, data1(1 To 50, 1 To 200) As tgz, data2(1 To 50, 1 To 200, 1 To 100) As tsf

这其中的 50 ， 200 ， 100 循环一次取得 60000行数据 用不了 0.1 秒 这个时间 还是值得花的

整个代码的通用型强一些

泓()

        If d3.Exists(xh) = False Then Set d3(xh) = New Dictionary 

        s = d3(xh)(gz)

        xhgz = arr(i, 2) & " " & arr(i, 3)    ' 型号 故障
        If d4.Exists(xhgz) = False Then Set d4(xhgz) = New Dictionary
        d4(xhgz)(arr(i, 1)) = d4(xhgz)(arr(i, 1)) + 1

ldy888,你好,以上代码我还迷惑（不解）中,循环结束时，d3,d4的Keys,Items,分别返回是？

有空时,解惑一下,谢谢.

[em05]

[此贴子已经被作者于2007-11-30 22:27:12编辑过]

彭希仁

看来字典树形结构设想算法要超过tycp兄的算法基本不可能了因为就构建一个树形结构库就花了1.6秒.字典树形结构设想算法再怎么优化都应该不会比LDY888兄的代码快到那里去.

    Dim d As New Dictionary
    r = Sheet2.[A65536].End(xlUp).Row - 1
    arr = Sheet2.Cells(2, 1).Resize(r, 3)

    t = Timer
    For i = 1 To r
        x = arr(i, 2)
        y = arr(i, 3)
        If Not d.Exists(x) Then Set d(x) = New Dictionary
        If Not d(x).Exists(y) Then Set d(x)(y) = New Dictionary
        d(x)(y)(arr(i, 1)) = d(x)(y)(arr(i, 1)) + 1
    Next i
    MsgBox Timer - t '已1.6秒
    Exit Sub

按照我的设想.后面可完全可套我排序加数组算法的后部分算法.

arrow518

确实是高手,原来以为我最厉害.....

ldy888

在循环中加 几句

tk3=d3.keys

tm3=d3.items

tk4=d4.keys

tm4=d4.items

按f8 逐步运行 在本地窗口查看

泓()

加上去的效果,就不一样,谢谢

wsri

由于不信邪，想看看用SQL语句的效果，做了3个小时，终于完工！完全可以达到彭兄要求的效果，但是没有优化，速度就太差了！如果加上数组应该会好一些。但也算是一种解法，凉凉给大家看看！献丑了！！！

Dim conn As New ADODB.Connection
   Dim rst As New ADODB.Recordset
   Dim rst1 As New ADODB.Recordset
    Dim rst2 As New ADODB.Recordset
Public Sub XTDR()
    Application.ScreenUpdating = False '关闭屏幕更新
    Application.EnableEvents = False   '关闭事件响应
    'Application.Interactive = False     '禁止所有的键盘输入和鼠标输入'
    Q = Timer
   
 Set conn = New ADODB.Connection                                '创建一个连接和打开 Cnn 连接
    Set rst = New ADODB.Recordset                                 '创建一个记录集
 conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
  
  Strsql = "Select DISTINCT 机型,故障 from [数据$] ORDER BY 机型 " ''where 机型" & Cells(rowbegin, colbegin) & "='" & Cells(i, 1) & "'"
  rst.Open Strsql, conn, adOpenKeyset, adLockOptimistic
 H = rst.RecordCount
 nn = H
'Sheets("报表").Cells(3, 2).CopyFromRecordset rst
T = 0
  If nn > 0 Then
 
  For I = 1 To nn
  'If T = 1 Then GoTo 100
   JX = IIf(IsNull(rst.Fields(0)), "", rst.Fields(0))
    GZ = IIf(IsNull(rst.Fields(1)), "", rst.Fields(1))
  JX1 = Sheets("报表").Cells(T + 2, 2)
   If JX = JX1 Or T = 0 Then
    T = T + 1
    P = P + 1
  
   Else
   Sheets("报表").Cells(T + 3, 2) = JX1
   Sheets("报表").Cells(T + 3, 3) = "合计"
   Sheets("报表").Cells(T + 3, 4) = ZSL
   Sheets("报表").Cells(T + 3, 5) = "100%"
   Sheets("报表").Cells(T + 3, 1) = P + 1
   T = T + 2
     P = 1
   End If
'100:
   
   Sheets("报表").Cells(T + 2, 1) = P
    Sheets("报表").Cells(T + 2, 2) = JX
    Sheets("报表").Cells(T + 2, 3) = GZ
 
  Strsql = "Select DISTINCT K.机型,K.故障,A.总数 AS 总数,B.数量 AS 数量 from (([数据$] K Left JOIN (Select DISTINCT 机型,COUNT(*) AS 总数 from [数据$] where 机型='" & JX & "' GROUP BY 机型) A ON K.机型=A.机型) " & _
" Left JOIN (Select DISTINCT 机型,故障,COUNT(*) AS 数量 from [数据$] where 机型='" & JX & "' AND 故障='" & GZ & "' GROUP BY 机型,故障) B  ON K.机型=B.机型 ) where K.机型='" & JX & "' AND K.故障='" & GZ & "'"
       
   rst1.Open Strsql, conn, adOpenKeyset, adLockOptimistic
 H = rst1.RecordCount
     SL = IIf(IsNull(rst1.Fields(3)), "", rst1.Fields(3))
    ZSL = IIf(IsNull(rst1.Fields(2)), "", rst1.Fields(2))
   
    Sheets("报表").Cells(T + 2, 4) = SL
    Sheets("报表").Cells(T + 2, 5) = Format(SL / ZSL, "#,00%")
    rst1.Close
 
  Strsql = "Select DISTINCT 省份,COUNT(*) AS 数量 from [数据$] where 机型='" & JX & "' AND 故障='" & GZ & "' GROUP BY 省份 ORDER BY COUNT(*)DESC "
  rst2.Open Strsql, conn, adOpenKeyset, adLockOptimistic
   H = rst2.RecordCount
   D = 0
   If H >= 3 Then
   L = 3
   Else
   L = H
   End If
   For B = 1 To L
   SF = IIf(IsNull(rst2.Fields(0)), "", rst2.Fields(0))
   SFSL = IIf(IsNull(rst2.Fields(1)), "", rst2.Fields(1))
   Sheets("报表").Cells(T + 2, 6 + (D * 2)) = SF
   Sheets("报表").Cells(T + 2, 7 + (D * 2)) = SFSL
   D = D + 1
   rst2.MoveNext
  
   Next B
   rst2.Close
    rst.MoveNext
   
    Next I
 Sheets("报表").Cells(T + 3, 2) = JX1
   Sheets("报表").Cells(T + 3, 3) = "合计"
   Sheets("报表").Cells(T + 3, 4) = ZSL
   Sheets("报表").Cells(T + 3, 5) = "100%"
   Sheets("报表").Cells(T + 3, 1) = P + 1
     End If
   
   rst.Close
   Set conn = Nothing
Set rst = Nothing
Set rst1 = Nothing
Set rst2 = Nothing
Sheets("报表").Cells(T + 4, 1) = Timer - Q

 Application.Interactive = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

o8jYXrYI.rar (21.4 KB, 下载次数: 10)

2007-12-1 01:53 上传

点击文件名下载附件
[讨论]有点难度的汇总

bjjgq

这样多重的分类汇总还是头一回看到

真的感觉到天外的天了

学习并期待中

BobPan

高手如云！！！

以前很少使用字典，看到此贴，看来要好好修练修练，感谢各位的精彩代码！