求大神帮忙这个代码

jieack

求大神帮忙这个代码怎么写，清单明细内数据我都写好了，点击统计数量，在统计数量表内统计数量和去除重复。

蓝桥玄霜

统计的例子：

ykcbf1100

这个附件不符合题意，但还是保留了吧。

ykcbf1100

说真的，没看懂图2

1. Sub ykcbf()   '//2024.12.24
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("清单明细").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     On Error Resume Next
   
7.     For i = 2 To UBound(arr) Step 2
   
8.         s = arr(i, 1) & "|" & arr(i, 2)
   
9.         If s <> Empty Then
   
10.             If Not d.exists(s) Then
    
11.                 m = m + 2
    
12.                 d(s) = m
    
13.                 brr(m - 1, 1) = arr(i, 1)
    
14.                 brr(m - 1, 2) = arr(i, 2)
    
15.                 For j = 3 To UBound(arr, 2)
    
16.                     brr(m - 1, j) = arr(i, j)
    
17.                     brr(m, j) = arr(i + 1, j)
    
18.                 Next
    
19.             Else
    
20.                 r = d(s)
    
21.                 For j = 3 To UBound(arr, 2)
    
22.                     brr(r, j) = brr(r, j) + arr(i + 1, j)
    
23.                 Next
    
24.             End If
    
25.         End If
    
26.     Next
    
27.     With Sheets("统计数量")
    
28.         .UsedRange.Offset(1).ClearContents
    
29.         .[a3].Resize(m, UBound(arr, 2)) = brr
    
30.         ActiveWindow.DisplayZeros = False
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    
36. 
    

复制代码

jieack

ykcbf1100 发表于 2024-12-24 10:44
猜一个吧。

老师 统计好后是这样的，这个是我手工统计的，是我需要这样的，好直接下单制作

ykcbf1100

jieack 发表于 2024-12-24 10:49
老师 统计好后是这样的，这个是我手工统计的，是我需要这样的，好直接下单制作

不太好理解啊
附件供参考。。。

ykcbf1100

修改一下。。。

1. Sub ykcbf()   '//2024.12.24
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("清单明细").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     On Error Resume Next
   
7.     For i = 2 To UBound(arr) Step 2
   
8.         s = arr(i, 1) & "|" & arr(i, 2)
   
9.         If s <> Empty Then
   
10.             If Not d.exists(s) Then
    
11.                 m = m + 1
    
12.                 d(s) = m
    
13.                 brr(m, 1) = arr(i, 1)
    
14.                 brr(m, 2) = arr(i, 2)
    
15.             End If
    
16.         End If
    
17.     Next
    
18.     Max = m
    
19.     For j = 3 To UBound(arr, 2)
    
20.         d.RemoveAll
    
21.         m = 0
    
22.         For i = 2 To UBound(arr) Step 2
    
23.             s = arr(i, j)
    
24.             If s <> Empty Then
    
25.                 If Not d.exists(s) Then
    
26.                     m = m + 2
    
27.                     d(s) = m
    
28.                     brr(m - 1, j) = arr(i, j)
    
29.                     brr(m, j) = arr(i + 1, j)
    
30.                 Else
    
31.                     r = d(s)
    
32.                     brr(r, j) = brr(r, j) + arr(i + 1, j)
    
33.                 End If
    
34.             End If
    
35.         Next
    
36.         Max = IIf(Max < m, m, Max)
    
37.     Next
    
38.     With Sheets("统计数量")
    
39.         .UsedRange.Offset(1).ClearContents
    
40.         .[a3].Resize(Max, UBound(arr, 2)) = brr
    
41.         ActiveWindow.DisplayZeros = False
    
42.     End With
    
43.     Set d = Nothing
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "OK！"
    
46. End Sub
    

复制代码

lizhipei78

JSA 参与一下

清单统计.rar (16.3 KB, 下载次数: 0)

2024-12-24 12:04 上传

点击文件名下载附件

lizhipei78