小白求助，相同品类单价相差不超过1的总计金额除以总计数量，得到新的单价

mm1g2c31

如图想把左边的所有数据变成右边的这种

chxw68

1. Sub test()
   
2.   Dim r%, i%, m%
   
3.   Dim arr, brr, zrr()
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     .Range("a2:e" & r).Sort key1:=.Range("a2"), order1:=xlAscending, key2:=.Range("c2"), order2:=xlAscending, Header:=xlNo
   
7.     arr = .Range("a2:e" & r)
   
8.     m = 0
   
9.     pm = Empty
   
10.     dj = Empty
    
11.     For i = 1 To UBound(arr)
    
12.       If arr(i, 1) <> pm Or Abs(arr(i, 3) - dj) > 1 Then
    
13.         m = m + 1
    
14.         ReDim Preserve zrr(1 To m)
    
15.         zrr(m) = Array(i, i)
    
16.         pm = arr(i, 1)
    
17.         dj = arr(zrr(m)(0), 3)
    
18.       Else
    
19.         If m > 0 Then
    
20.           zrr(m)(1) = i
    
21.         End If
    
22.       End If
    
23.     Next
    
24.     ReDim brr(1 To UBound(zrr), 1 To UBound(arr, 2))
    
25.     For k = 1 To UBound(zrr)
    
26.       brr(k, 1) = arr(zrr(k)(0), 1)
    
27.       brr(k, 2) = arr(zrr(k)(0), 2)
    
28.       For i = zrr(k)(0) To zrr(k)(1)
    
29.         brr(k, 4) = brr(k, 4) + arr(i, 4)
    
30.         brr(k, 5) = brr(k, 5) + arr(i, 5)
    
31.       Next
    
32.       brr(k, 3) = Round(brr(k, 5) / brr(k, 4), 3)
    
33.     Next
    
34.     .Range("h2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
35.   End With
    
36.    
    
37. End Sub
    

复制代码

chxw68

详见附件。

mm1g2c31

chxw68 发表于 2021-8-29 22:39
详见附件。

哇，谢谢chxw68大大！前面做的眼睛都快瞎了，再次感谢