数据分析（不使用数据透视表）

praijna

各位老师：
原始数据如附件，区域为 A2:D160，第一步要达到的数据处理结果是 E2:F26,第二步到达到的数据结果是 G2:AP26, 第一步可以根据gvntw 版主的VBA字典方法完成，代码如下：
20081018A.rar (10.76 KB, 下载次数: 75)

2008-12-2 16:46 上传

点击文件名下载附件
数据表格

Sub test()
   Set d = CreateObject("Scripting.Dictionary")
   For i = 2 To [A65536].End(xlUp).Row
        d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + 1
    Next
    [F3].Resize(d.Count) = Application.Transpose(d.keys)
    [G3].Resize(d.Count) = Application.Transpose(d.items)
    Set d = Nothing
End Sub
如何完成根据E2:F26的数据得到G2:AP26的数据结果的代码呢？

谢谢！

smhf_6

没看清您的要求用了数据透视表故删除

[ 本帖最后由 smhf_6 于 2008-12-2 19:21 编辑 ]

蓝桥玄霜

Sub yy()
Dim Myre%, x%, aa$, k, t, i%
Dim d, xx, fsad, r1, n
Myre = [e65536].End(xlUp).Row
For x = 2 To Myre
    aa = Cells(x, 5)
    With Range("a:a")
    Set r1 = .Find(aa)
    fsad = r1.Address
    xx = Cells(r1.Row, 2)
    Set d = CreateObject("scripting.dictionary") '定义字典
        If Not d.exists(xx) Then
            d.Add xx, 1
        Else
            d(xx) = d(xx) + 1
            
        End If
    Do
        Set r1 = .FindNext(r1)
        n = r1.Address
        If n <> fsad Then
            xx = Cells(r1.Row, 2)
            If Not d.exists(xx) Then
                d.Add xx, 1
            Else
                d(xx) = d(xx) + 1
            
            End If
        End If
    Loop While r1.Address <> fsad
    End With
    k = d.keys
    t = d.items
    For i = 0 To UBound(k)
        Cells(x, 2 * i + 7) = k(i)
        Cells(x, 2 * i + 8) = t(i)
    Next i
    Set d = Nothing
Next x
End Sub

figfig

Sub fig8()

Set x = CreateObject("ADODB.CONNECTION")


x.Open = "Provider = MSDataShape;data provider=microsoft.jet.oledb.4.0;EXTENDED PROPERTIES='EXCEL 8.0;HDR=YES;';data source=" & ThisWorkbook.FullName

Set y1 = x.Execute(" shape (shape {select * from [Report$A1:D888]} as cc compute any(cc.CRD) as MMM,count(cc.CRD) as NNN ,CC  by Defect ,[Detection Router],CRD  ) as dd")

Set y = x.Execute("shape (shape {select * from [Report$A1:D888]}  append (dd relate Defect to Defect) as vv) as aa compute any(aa.Defect) as mm,count(aa.CRD) as nn,aa by Defect")
i = 2
Do While Not y.EOF
Cells(i, 5) = y!mm
Cells(i, 6) = y!nn
Set y2 = y!aa.Value
Set y3 = y2!vv.Value
j = 7
Do While Not y3.EOF
Cells(i, j) = y3!MMM
Cells(i, j + 1) = y3!NNN
y3.MOVENEXT
j = j + 2
Loop
y.MOVENEXT
i = i + 1
Loop
End Sub

[ 本帖最后由 figfig 于 2008-12-2 21:28 编辑 ]

praijna

非常感谢3楼、4楼两位老师的帮助！
还有一个问题：E2:F26，G2:AP26 区数据没有按照Qty 的大小从大至小排序，能否再加些代码？

[ 本帖最后由 praijna 于 2008-12-3 08:28 编辑 ]

praijna

各位老师：
麻烦你抽空帮忙看看，好吗？



谢谢！

figfig

原帖由 praijna 于 2008-12-3 08:26 发表
非常感谢3楼、4楼两位老师的帮助！
还有一个问题：E2:F26，G2:AP26 区数据没有按照Qty 的大小从大至小排序，能否再加些代码？

Sub fig8()

Set x = CreateObject("ADODB.CONNECTION")


x.Open = "Provider = MSDataShape;data provider=microsoft.jet.oledb.4.0;EXTENDED PROPERTIES='EXCEL 8.0;HDR=YES;';data source=" & ThisWorkbook.FullName

Set y1 = x.Execute(" shape (shape {select * from [Report$A1:D888]} as cc compute any(cc.CRD) as MMM,count(cc.CRD) as NNN ,CC  by Defect ,[Detection Router],CRD  ) as dd")

Set y = x.Execute("shape (shape {select * from [Report$A1:D888]}  append ( dd relate Defect to Defect) as vv) as aa compute any(aa.Defect) as mm,count(aa.CRD) as nn,aa by Defect")
i = 2
y.Sort = "nn desc"
Do While Not y.EOF
Cells(i, 5) = y!mm
Cells(i, 6) = y!nn
Set y2 = y!aa.Value
Set y3 = y2!vv.Value
y3.Sort = "NNN desc"
j = 7
Do While Not y3.EOF
Cells(i, j) = y3!MMM
Cells(i, j + 1) = y3!NNN
y3.MOVENEXT
j = j + 2
Loop
y.MOVENEXT
i = i + 1
Loop
End Sub

johnny519

countif 函数也可以哦，似乎可以不用代码

praijna

figfig：
早上好！
非常感谢您的帮助！


谢谢！

praijna

各位老师：
在使用 figfig 的代码时，发现有一个小小的错误，因为一时间没有能够联系上 figfig ，因此再次将这个问题反映到论坛上来：

黄色填充区域即为 figfig 代码的结果。
Defect Report.rar (14.09 KB, 下载次数: 40)

2008-12-10 09:04 上传

点击文件名下载附件
代码 Excle