相同名称和相同规格产品数量汇总

tiantao186

求一个同名数据同规格的产品数量汇总

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.20
   
2.     Dim arr, brr, crr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("数据统计")
   
8.     With sh
   
9.         rq1 = CLng(DateValue(.[b1]))
   
10.         rq2 = CLng(DateValue(.[b2]))
    
11.     End With
    
12.     With ws.Sheets("出入库台账")
    
13.         r = .Cells(Rows.Count, 1).End(3).Row
    
14.         arr = .Range("a1:j" & r)
    
15.     End With
    
16.     ReDim brr(1 To UBound(arr), 1 To 8)
    
17.     ReDim crr(1 To UBound(arr), 1 To 8)
    
18.     On Error Resume Next
    
19.     For i = 2 To UBound(arr)
    
20.         s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    
21.         rq = CLng(arr(i, 4))
    
22.         If rq >= rq1 And rq <= rq2 Then
    
23.             If Not d.exists(s) Then
    
24.                 m = m + 1
    
25.                 d(s) = m
    
26.                 brr(m, 1) = arr(i, 1)
    
27.                 brr(m, 2) = arr(i, 2)
    
28.                 brr(m, 3) = arr(i, 3)
    
29.                 For j = 5 To 9
    
30.                     brr(m, j) = arr(i, j)
    
31.                 Next
    
32.             Else
    
33.                 r = d(s)
    
34.                 brr(r, j) = brr(r, j) + arr(i, j)
    
35.             End If
    
36.             If Not d1.exists(s) Then
    
37.                 n = n + 1
    
38.                 d1(s) = n
    
39.                 crr(n, 1) = arr(i, 1)
    
40.                 crr(n, 2) = arr(i, 2)
    
41.                 crr(n, 3) = arr(i, 3)
    
42.                 For j = 5 To 9
    
43.                     crr(n, j) = arr(i, j)
    
44.                 Next
    
45.             Else
    
46.                 r = d1(s)
    
47.                 crr(r, j) = crr(r, j) + arr(i, j)
    
48.             End If
    
49.         End If
    
50.     Next
    
51.     With ws.Sheets("日期统计")
    
52.         .UsedRange.Offset(1).Clear
    
53.         With .[a2].Resize(m, 8)
    
54.             .Value = brr
    
55.             .Borders.LineStyle = 1
    
56.             .HorizontalAlignment = xlCenter
    
57.             .VerticalAlignment = xlCenter
    
58.         End With
    
59.     End With
    
60.     With ws.Sheets("商品名称统计")
    
61.         .UsedRange.Offset(1).Clear
    
62.         With .[a2].Resize(n, 8)
    
63.             .Value = crr
    
64.             .Borders.LineStyle = 1
    
65.             .HorizontalAlignment = xlCenter
    
66.             .VerticalAlignment = xlCenter
    
67.         End With
    
68.     End With
    
69.     Application.ScreenUpdating = True
    
70.     MsgBox "OK！"
    
71. End Sub
    

复制代码

limonet

两个表：日期统计VS商品名称统计没见区别。

tiantao186

ykcbf1100 发表于 2024-2-20 17:29
附件供参考。。。

大神，能不能给修改一下，商品名称统计（不区分日期，条件是品名和规格，相同的合并）。日期统计（条件是品名和规格，相同的合并，区分日期）。现在2个效果好像都一样

ykcbf1100

tiantao186 发表于 2024-2-22 13:11
大神，能不能给修改一下，商品名称统计（不区分日期，条件是品名和规格，相同的合并）。日期统计（条件是 ...

可以修改，稍等一下。

ykcbf1100

tiantao186 发表于 2024-2-22 13:11
大神，能不能给修改一下，商品名称统计（不区分日期，条件是品名和规格，相同的合并）。日期统计（条件是 ...

修改好了。。。

tiantao186

ykcbf1100 发表于 2024-2-22 13:19
修改好了。。。

老师能否再修改一下，用相同品名测试一下，数据没有汇总

ykcbf1100

tiantao186 发表于 2024-2-22 14:35
老师能否再修改一下，用相同品名测试一下，数据没有汇总

改好了。。。

ykcbf1100

更新后代码。

1. Sub ykcbf()  '//2024.2.20
   
2.     Dim arr, brr, crr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("数据统计")
   
8.     With sh
   
9.         rq1 = CLng(DateValue(.[b1]))
   
10.         rq2 = CLng(DateValue(.[b2]))
    
11.     End With
    
12.     With ws.Sheets("出入库台账")
    
13.         r = .Cells(Rows.Count, 1).End(3).Row
    
14.         arr = .Range("a1:j" & r)
    
15.     End With
    
16.     ReDim brr(1 To UBound(arr), 1 To 3)
    
17.     ReDim crr(1 To UBound(arr), 1 To 3)
    
18.     On Error Resume Next
    
19.     For i = 2 To UBound(arr)
    
20.         s = arr(i, 1) & "|" & arr(i, 2)
    
21.         rq = CLng(arr(i, 4))
    
22.         If Not d1.exists(s) Then
    
23.             n = n + 1
    
24.             d1(s) = n
    
25.             brr(n, 1) = arr(i, 1)
    
26.             brr(n, 2) = arr(i, 2)
    
27.             brr(n, 3) = arr(i, 5)
    
28.         Else
    
29.             r = d1(s)
    
30.             brr(r, 3) = brr(r, 3) + arr(i, 5)
    
31.         End If
    
32.         If rq >= rq1 And rq <= rq2 Then
    
33.             If Not d.exists(s) Then
    
34.                 m = m + 1
    
35.                 d(s) = m
    
36.                 crr(m, 1) = arr(i, 1)
    
37.                 crr(m, 2) = arr(i, 2)
    
38.                 crr(m, 3) = arr(i, 5)
    
39.             Else
    
40.                 r = d(s)
    
41.                 crr(r, 3) = crr(r, 3) + arr(i, 5)
    
42.             End If
    
43.         End If
    
44.     Next
    
45.     With ws.Sheets("日期统计")
    
46.         .UsedRange.Offset(1).Clear
    
47.         With .[a2].Resize(m, 3)
    
48.             .Value = brr
    
49.             .Borders.LineStyle = 1
    
50.             .HorizontalAlignment = xlCenter
    
51.             .VerticalAlignment = xlCenter
    
52.         End With
    
53.     End With
    
54.     With ws.Sheets("商品名称统计")
    
55.         .UsedRange.Offset(1).Clear
    
56.         With .[a2].Resize(n, 3)
    
57.             .Value = crr
    
58.             .Borders.LineStyle = 1
    
59.             .HorizontalAlignment = xlCenter
    
60.             .VerticalAlignment = xlCenter
    
61.         End With
    
62.     End With
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "OK！"
    
65. End Sub
    

复制代码