[已解决]急急急！！小妹再次来拜托各位大神啦~~大量数据比较分组的编程问题

啦啦游游

最新的附件在4楼！！
sheet1是原有数据，sheet2是我手输的需要得到的结果，可以做个对照~~

实际数据远大于附件的例子，现在需要按例子的group分组比较
在相同组内的material两两比较其中Weight这一个参数再次分组，weight相同的则分为一个小组，并在newname一栏标出新的小组名，amount一栏写出同在一个新的小组的material的数量，same material则写出与该material可能相同的所有material ID。
如果为参数为空格也视为不等于其他已知值
例如：黄色部分为需编程运行得出的结果，具体例题请见附件
material  ID         weight        group          same material      newname    amount
1                            0               1                        3                  group A1        2   
2                            1               1                                           group A2        1
3                            0               1                        1                  group A1        2
4                                             1                                           group A3        1
5                            0               2                                            group B1        1


拜托各位大神帮帮忙{:091:}

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-8 09:48

看看合意否？

1. Sub grf()
   
2.     Set d = CreateObject("scripting.dictionary")    '数量
   
3.     Set d1 = CreateObject("scripting.dictionary")   '相同材料
   
4.     Set d2 = CreateObject("scripting.dictionary")    '新组别的字母
   
5.     Set d3 = CreateObject("scripting.dictionary")    '新组别的数字
   
6.     arr = [a1].CurrentRegion
   
7.     zb = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   
8.     ReDim brr(2 To UBound(arr), 1 To 4)
   
9.     For i = 2 To UBound(arr)
   
10.         If Not d2.exists(arr(i, 6)) Then     '对组别分组，取得新组别的字母
    
11.             n = n + 1
    
12.             d2(arr(i, 6)) = Mid(zb, n, 1)    '字母
    
13.             m = 0
    
14.         End If
    
15.         x = arr(i, 6) & "," & arr(i, 2)  '以组别+重量为key
    
16.         If Not d3.exists(x) Then        '相同组中对重量分组，取得新组别的数字
    
17.             m = m + 1
    
18.             d3(x) = m
    
19.         End If
    
20.         brr(i, 3) = d2(arr(i, 6)) & d3(x)   '新组别：字母+数字
    
21.         d(x) = d(x) + 1  '组别+重量的数量
    
22.         d1(x) = d1(x) & "," & arr(i, 1)       '组别+重量的材料编号串
    
23.     Next
    
24.     For i = 2 To UBound(arr)
    
25.         x = arr(i, 6) & "," & arr(i, 2)  '以组别+重量为key
    
26.         brr(i, 4) = d(x)     '数量
    
27.         s = Replace(d1(x) & ",", "," & arr(i, 1) & ",", ",")   '材料编号串中去掉本材料
    
28.         If Len(s) = 1 Then s = "" Else s = Mid(s, 2, Len(s) - 2)   '去掉两头的逗号
    
29.         brr(i, 1) = s
    
30.     Next
    
31.     [H2].Resize(UBound(arr) - 1, 4) = brr
    
32. End Sub

复制代码

跳转到最佳答案楼层

爱疯

不清楚要做什么，建议：
1）sheet1是处理前，sheet2是处理后（你手动给出）
2）字段名先用中文，更易理解题意。

啦啦游游

爱疯 发表于 2015-12-7 19:56
不清楚要做什么，建议：
1）sheet1是处理前，sheet2是处理后（你手动给出）
2）字段名先用中文，更易 ...

好的稍等，我手输一下结果在sheet2里面，好了我上传新附件~~
麻烦等等再看一看啦

啦啦游游

结果在sheet2中
最后我运用起来的时候实际数据“重量”参数不一定在第二列，需要得出的几个结果也不是在例题中的列数，也不止这么几个原组别，所以需要程序自己检测出需要提取和输入数据的地方
谢谢啦

啦啦游游

爱疯 发表于 2015-12-7 19:56
不清楚要做什么，建议：
1）sheet1是处理前，sheet2是处理后（你手动给出）
2）字段名先用中文，更易 ...

新附件发好了，
在同一个原组别内的材料两两比较“重量”是否相同，比较时其他的参数都可以忽略，只比较“重量”这一列的参数，相同的就又再细分为一个小组，并在数量一栏里输入每一个新组别里包含了几个材料

grf1973

看看合意否？

1. Sub grf()
   
2.     Set d = CreateObject("scripting.dictionary")    '数量
   
3.     Set d1 = CreateObject("scripting.dictionary")   '相同材料
   
4.     Set d2 = CreateObject("scripting.dictionary")    '新组别的字母
   
5.     Set d3 = CreateObject("scripting.dictionary")    '新组别的数字
   
6.     arr = [a1].CurrentRegion
   
7.     zb = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   
8.     ReDim brr(2 To UBound(arr), 1 To 4)
   
9.     For i = 2 To UBound(arr)
   
10.         If Not d2.exists(arr(i, 6)) Then     '对组别分组，取得新组别的字母
    
11.             n = n + 1
    
12.             d2(arr(i, 6)) = Mid(zb, n, 1)    '字母
    
13.             m = 0
    
14.         End If
    
15.         x = arr(i, 6) & "," & arr(i, 2)  '以组别+重量为key
    
16.         If Not d3.exists(x) Then        '相同组中对重量分组，取得新组别的数字
    
17.             m = m + 1
    
18.             d3(x) = m
    
19.         End If
    
20.         brr(i, 3) = d2(arr(i, 6)) & d3(x)   '新组别：字母+数字
    
21.         d(x) = d(x) + 1  '组别+重量的数量
    
22.         d1(x) = d1(x) & "," & arr(i, 1)       '组别+重量的材料编号串
    
23.     Next
    
24.     For i = 2 To UBound(arr)
    
25.         x = arr(i, 6) & "," & arr(i, 2)  '以组别+重量为key
    
26.         brr(i, 4) = d(x)     '数量
    
27.         s = Replace(d1(x) & ",", "," & arr(i, 1) & ",", ",")   '材料编号串中去掉本材料
    
28.         If Len(s) = 1 Then s = "" Else s = Mid(s, 2, Len(s) - 2)   '去掉两头的逗号
    
29.         brr(i, 1) = s
    
30.     Next
    
31.     [H2].Resize(UBound(arr) - 1, 4) = brr
    
32. End Sub

复制代码

grf1973

原数据必须是按组别排过序的，不然新组别会出错。

啦啦游游

grf1973 发表于 2015-12-8 09:49
原数据必须是按组别排过序的，不然新组别会出错。

谢谢啦~