按条件分组

wqhsz385919

实在做不到，麻烦大侠看下，
帮忙分组：
分组条件如下
1.一个组允许多个料号存在
2.每组金额不能超过10万
3.每组不能存在同一个料号不同单价
4.在E列备注第几组

详见附件模拟

kyxfyzg

附件参考。。。。。。。。。。

wqhsz385919

kyxfyzg 发表于 2024-9-2 16:41
附件参考。。。。。。。。。。

感谢出手，已核对，但结果不对
不符合分组条件：
每组不能存在同一个编码不同的单价

醉眼看尘世

1. Sub test()
   
2. Dim Dic As Object, Dib As Object, Arr, i&, x%, tmPje As Double, zB%
   
3. Set Dic = CreateObject("scripting.dictionary")
   
4. Set Dib = CreateObject("scripting.dictionary")
   
5. Arr = [B1].Resize(Cells(Rows.Count, "b").End(3).Row, 5)
   
6. x = UBound(Arr, 1) - 1
   
7. zB = 0
   
8. Do While x > 0
   
9.     tmPje = 0
   
10.     Dic.RemoveAll: Dib.RemoveAll
    
11.     For i = 2 To UBound(Arr, 1)
    
12.         If Arr(i, 5) = "" Then
    
13.             If Not Dic.exists(Arr(i, 1)) Then Dic(Arr(i, 1)) = Arr(i, 3)
    
14.             If Dic(Arr(i, 1)) = Arr(i, 3) Then
    
15.                 tmp = tmPje + Arr(i, 4)
    
16.                 If tmp <= 100000 Then
    
17.                     x = x - 1
    
18.                     Arr(i, 5) = "Yes"
    
19.                     tmPje = tmp
    
20.                     Dib(i) = ""
    
21.                 Else
    
22.                     Exit For
    
23.                 End If
    
24.             End If
    
25.         End If
    
26.     Next i
    
27.     zB = zB + 1
    
28.     For Each k In Dib.keys
    
29.         Arr(k, 5) = zB
    
30.     Next k
    
31. Loop
    
32. For i = 2 To UBound(Arr, 1) - 1
    
33.     For j = i + 1 To UBound(Arr, 1)
    
34.         If Arr(j, 5) < Arr(i, 5) Then
    
35.             For k = 1 To UBound(Arr, 2)
    
36.                 tmp = Arr(i, k): Arr(i, k) = Arr(j, k): Arr(j, k) = tmp
    
37.             Next k
    
38.         End If
    
39.     Next j
    
40. Next i
    
41. [w1].Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
    
42. End Sub
    

复制代码

yanglinzi

1. Sub 分组() '\\2024-9-2
   
2. Dim arr, brr, i, j, r, n, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     r = .Cells(Rows.Count, 2).End(xlUp).Row
   
6.     arr = .[a1].Resize(r, 6)
   
7. End With
   
8. n = 1
   
9. For i = 2 To UBound(arr)
   
10.     sa = arr(i, 2)
    
11.     d(sa) = arr(i, 4)
    
12.     If arr(i, 4) = d(sa) Then
    
13.         s = s + arr(i, 5)
    
14.     End If
    
15.     If s < 100000 Then
    
16.         arr(i, 6) = "第" & n & "组"
    
17.     Else
    
18.         n = n + 1
    
19.         arr(i, 6) = "第" & n & "组"
    
20.         s = arr(i, 5)
    
21.     End If
    
22. Next
    
23. Range("f2:f" & r).ClearContents
    
24. [f1].Resize(r) = Application.Index(arr, 0, 6)
    
25. End Sub
    

复制代码

yanglinzi

请测试。。

wqhsz385919

醉眼看尘世 发表于 2024-9-2 17:15

结果非常正确，速度非常快！

wqhsz385919

yanglinzi 发表于 2024-9-2 17:43
请测试。。

感谢帮助，已核对，但结果不对
不符合分组条件：
每组不能存在同一个编码不同的单价

wqhsz385919

醉眼看尘世 发表于 2024-9-2 17:15

我是在WPS环境下运行，现在发现运行不了了
报ZB=ZB+1溢出，把ZB由ZB%改成ZB&,反应比较慢，出不了结果

rysxing

jsa,试试。。。。。。