繁琐的分类统计

youngnju · 发表于 2018-7-19 22:13

对每一个厂家和类型，分别统计出前三个产品最多的失效项目，列出产品名称，按照失效产品数量从多到少排序，并整理成以下的结果表格。因为要经常做这类统计，所以请各位大侠帮忙写个程序，谢谢！

fsq119 · 发表于 2018-7-20 00:42

Public Sub xx()
arr = Range("a2:e" & [a65536].End(3).Row)
Set dic = CreateObject("scripting.dictionary")
n = 1
For k = 4 To 5
For i = 1 To UBound(arr, 1)
      brr = Split(arr(i, k), ",")
      For j = LBound(brr) To UBound(brr)
         dic(arr(i, 1) & "," & arr(i, 2) & "," & brr(j)) = dic(arr(i, 1) & "," & arr(i, 2) & "," & brr(j)) & "," & arr(i, 3)
      Next
Next
For i = 1 To dic.Count
      drr = Split(Application.Index(dic.keys, i), ",")
      c = UBound(Split(Application.Index(dic.items, i), ","))
      With Range("g" & n)
         .Offset(i, 0).Resize(1, 3) = drr
         .Offset(i, 3) = c
         .Offset(i, 4) = Application.Index(dic.items, i)
      End With
Next
n = [g65536].End(3).Row + 1
dic.RemoveAll
Next k
End Sub

youngnju · 发表于 2018-7-20 17:14

fsq119 发表于 2018-7-20 00:42
Public Sub xx()
arr = Range("a2:e" & [a65536].End(3).Row)
Set dic = CreateObject("scripting.dictio ...

谢谢大侠，能基本实现我想要的功能。

不过有两个小问题：
1. 我只需要失效产品最多的前三个失效项目，并进行从多到少进行排序。
2. 每个失效项之间要隔一行，同一个产家和类型的失效项目1和失效项目2要放在表格的两边。
详细请看结果图。

可以实现吗？

youngnju · 发表于 2018-7-20 19:51

还有一个问题是失效项目1和失效项目2的名称有可能相同的，按照你的程序，会混在一起。

chxw68 · 发表于 2018-7-20 21:33

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("原始数据")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:e" & r)
End With
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 1)).exists(arr(i, 2)) Then
Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
End If
For j = 4 To 5
If Not d(arr(i, 1))(arr(i, 2)).exists(j) Then
Set d(arr(i, 1))(arr(i, 2))(j) = CreateObject("scripting.dictionary")
End If
arr(i, j) = Replace(arr(i, j), " ", "")
brr = Split(arr(i, j), ",")
For k = 0 To UBound(brr)
If Not d(arr(i, 1))(arr(i, 2))(j).exists(brr(k)) Then
Set d(arr(i, 1))(arr(i, 2))(j)(brr(k)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 1))(arr(i, 2))(j)(brr(k))(arr(i, 3)) = ""
Next
Next
Next
With Worksheets("结果")
.UsedRange.Offset(1, 0).ClearContents
m = 2
For Each aa In d.keys
For Each bb In d(aa).keys
For k = 4 To 5
kk = d(aa)(bb)(k).keys
For i = 0 To UBound(kk) - 1
p = i
For j = i + 1 To UBound(kk)
If d(aa)(bb)(k)(kk(p)).Count < d(aa)(bb)(k)(kk(j)).Count Then
p = j
End If
Next
If p <> i Then
temp = kk(i)
kk(i) = kk(p)
kk(p) = temp
End If
Next
For i = 0 To Application.Min(2, UBound(kk))
.Cells(m + i, k * 5 - 19) = aa
.Cells(m + i, k * 5 - 19 + 1) = bb
.Cells(m + i, k * 5 - 19 + 2) = kk(i)
.Cells(m + i, k * 5 - 19 + 3) = d(aa)(bb)(k)(kk(i)).Count
.Cells(m + i, k * 5 - 19 + 4) = Join(d(aa)(bb)(k)(kk(i)).keys, ",")
Next
Next
m = m + 4
Next
Next
End With
End Sub

复制代码

chxw68 · 发表于 2018-7-20 21:34

详见附件。

chxw68 · 发表于 2018-7-20 21:37

youngnju 发表于 2018-7-20 17:14
谢谢大侠，能基本实现我想要的功能。

不过有两个小问题：

楼主说得非常准确！这个问题就是比较繁琐。

chxw68 · 发表于 2018-7-20 21:37

youngnju 发表于 2018-7-20 17:14
谢谢大侠，能基本实现我想要的功能。

不过有两个小问题：

楼主说得非常准确！这个问题就是比较繁琐。

chxw68 · 发表于 2018-7-20 21:38

youngnju 发表于 2018-7-20 17:14
谢谢大侠，能基本实现我想要的功能。

不过有两个小问题：

楼主说得非常准确！这个问题就是比较繁琐。

不知道为什么 · 发表于 2018-7-20 22:25

chxw68 发表于 2018-7-20 21:34
详见附件。

褚老师的活让人顿感敬佩！

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

[求助] 繁琐的分类统计

评分