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

praijna · 发表于 2008-12-2 16:46

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

20081018A.rar (10.76 KB, 下载次数: 75)
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 · 发表于 2008-12-2 19:18

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

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

蓝桥玄霜 · 发表于 2008-12-2 20:36

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 · 发表于 2008-12-2 21:26

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 · 发表于 2008-12-3 08:26

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

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

praijna · 发表于 2008-12-4 10:35

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

谢谢！

figfig · 发表于 2008-12-4 17:36

原帖由 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 · 发表于 2008-12-5 00:22

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

praijna · 发表于 2008-12-5 08:38

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

谢谢！

praijna · 发表于 2008-12-10 09:04

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

黄色填充区域即为 figfig 代码的结果。

Defect Report.rar (14.09 KB, 下载次数: 40)

		自动登录	找回密码
密码			免费注册

[求助] 数据分析（不使用数据透视表）