求SUMIFS，太卡了，想利用VBA来指定条件汇总

ykcbf1100

修正对比表AB列重复值问题。

1. Sub ykcbf()   '//2024.7.9
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("对比表")
   
5.     With sh
   
6.         xs = .[c2].Value
   
7.         yf = Split(.[f2].Value, "-")
   
8.     End With
   
9.     With Sheets("2024年")
   
10.         r = .Cells(Rows.Count, 1).End(3).Row
    
11.         c = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r, c)
    
13.     End With
    
14.     ReDim brr(1 To UBound(arr), 1 To 2)
    
15.     b = Array(15, 9, 10, 14, 24, 11)
    
16.     For i = 2 To UBound(arr)
    
17.         If arr(i, 38) = xs And arr(i, 41) = "是" Then
    
18.             If Val(arr(i, 33)) >= Val(yf(0)) And Val(arr(i, 33)) <= Val(yf(1)) Then
    
19.                 s = arr(i, 4) & "|" & arr(i, 28)
    
20.                 If Not d1.exists(s) Then
    
21.                     m = m + 1
    
22.                     d1(s) = m
    
23.                     brr(m, 1) = arr(i, 4)
    
24.                     brr(m, 2) = arr(i, 28)
    
25.                 End If
    
26.                 If Not d.exists(s) Then
    
27.                     d(s) = Array(arr(i, 15), arr(i, 9), arr(i, 10), arr(i, 14), arr(i, 24), arr(i, 11))
    
28.                 Else
    
29.                     t = d(s)
    
30.                     For x = 0 To 5
    
31.                         t(x) = t(x) + arr(i, b(x))
    
32.                     Next
    
33.                     d(s) = t
    
34.                 End If
    
35.             End If
    
36.         End If
    
37.     Next
    
38.     On Error Resume Next
    
39.     With sh
    
40.         .UsedRange.Offset(3).ClearContents
    
41.         .[a4].Resize(m, 2) = brr
    
42.         With .[a4].Resize(m, 16)
    
43.             .Borders.LineStyle = 1
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.         End With
    
47.         For i = 4 To m + 3
    
48.             s = .Cells(i, 1) & "|" & .Cells(i, 2)
    
49.             If d.exists(s) Then
    
50.                 t = d(s)
    
51.                 .Cells(i, 3) = t(0)
    
52.                 .Cells(i, 4) = t(1)
    
53.                 .Cells(i, 5) = t(2)
    
54.                 .Cells(i, 6) = t(3)
    
55.                 .Cells(i, 7) = t(3) / t(2)
    
56.                 .Cells(i, 8) = t(4) / t(2)
    
57.                 .Cells(i, 9) = t(5) / t(2)
    
58.             End If
    
59.         Next
    
60.     End With
    
61.     d.RemoveAll
    
62.     With Sheets("2023年")
    
63.         r = .Cells(Rows.Count, 1).End(3).Row
    
64.         c = .UsedRange.Columns.Count
    
65.         arr = .[a1].Resize(r, c)
    
66.     End With
    
67.    
    
68.     For i = 2 To UBound(arr)
    
69.         If arr(i, 38) = xs And arr(i, 41) = "是" Then
    
70.             If Val(arr(i, 33)) >= Val(yf(0)) And Val(arr(i, 33)) <= Val(yf(1)) Then
    
71.                 s = arr(i, 4) & "|" & arr(i, 28)
    
72.                 If Not d.exists(s) Then
    
73.                     d(s) = Array(arr(i, 15), arr(i, 9), arr(i, 10), arr(i, 14), arr(i, 24), arr(i, 11))
    
74.                 Else
    
75.                     t = d(s)
    
76.                     For x = 0 To 5
    
77.                         t(x) = t(x) + arr(i, b(x))
    
78.                     Next
    
79.                     d(s) = t
    
80.                 End If
    
81.             End If
    
82.         End If
    
83.     Next
    
84.     With sh
    
85.         For i = 4 To m + 3
    
86.             s = .Cells(i, 1) & "|" & .Cells(i, 2)
    
87.             If d.exists(s) Then
    
88.                 t = d(s)
    
89.                 .Cells(i, 10) = t(0)
    
90.                 .Cells(i, 11) = t(1)
    
91.                 .Cells(i, 12) = t(2)
    
92.                 .Cells(i, 13) = t(3)
    
93.                 .Cells(i, 14) = t(3) / t(2)
    
94.                 .Cells(i, 15) = t(4) / t(2)
    
95.                 .Cells(i, 16) = t(5) / t(2)
    
96.             End If
    
97.         Next
    
98.     End With
    
99.     Set d = Nothing
    
100.     MsgBox "OK！"
     
101. End Sub
     
102. 
     

复制代码

莫莫11111

ykcbf1100 发表于 2024-7-9 09:35
查了一下，对比表AB列确实存在重复值，现改好了。

您看看，这个是不是少2条数据，为啥呢

莫莫11111

ykcbf1100 发表于 2024-7-9 09:27
我查了2024年表中的C09P51RV67，符合条件的销量是407,和对比表中的第4行数据对上了的，应该没错。

q列的数据都会清空么？

ykcbf1100

莫莫11111 发表于 2024-7-9 09:47
q列的数据都会清空么？

现在的代码是：对比表第4行以下全部清空。如果你只想清除A~P列数据，那代码需要改一下。

莫莫11111

ykcbf1100 发表于 2024-7-9 09:52
现在的代码是：对比表第4行以下全部清空。如果你只想清除A~P列数据，那代码需要改一下。

这里对比了一下，少2条数据？

莫莫11111

VBA出来的数据

莫莫11111

ykcbf1100 发表于 2024-7-9 09:52
现在的代码是：对比表第4行以下全部清空。如果你只想清除A~P列数据，那代码需要改一下。

对的，只想清除A~P列数据

ykcbf1100

莫莫11111 发表于 2024-7-9 09:59
VBA出来的数据

为什么你汇总的结果和我的不一样呢？难道你改了代码？

莫莫11111

ykcbf1100 发表于 2024-7-9 10:10
为什么你汇总的结果和我的不一样呢？难道你改了代码？

没有修改过数据，我也是下载测试的，你刚刚一说，我又去下载了，还是一样结果

莫莫11111

ykcbf1100 发表于 2024-7-9 09:39
修正对比表AB列重复值问题。

我复制这个代码，那数据又出来的哦，奇怪，可以麻烦改一下，只清空A-P列的数据么