[已解决]各位老师写出这组代码有难度！不要公式，公式写咱也会的！在线等！

l2828486

当选下拉菜单的条件时，按查询结果第一列、第二列重复，第三列不重复，第五、第六列相同项的数量，利润汇总

最佳答案

月排行榜 / 总排行榜

grf1973

2016-3-16 10:21

1. Sub grf()
   
2.     dz = [b1]: cj = [e1]    '地址，厂家
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 5)
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 1) = dz And arr(i, 2) = cj Then      '条件相符
   
8.             x = arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5)        '以商品名称、型号、波段为key
   
9.             If Not d.exists(x) Then
   
10.                 n = n + 1
    
11.                 d(x) = n
    
12.                 brr(n, 1) = arr(i, 3)
    
13.                 brr(n, 2) = arr(i, 4)
    
14.                 brr(n, 3) = arr(i, 5)
    
15.             End If
    
16.             brr(d(x), 4) = brr(d(x), 4) + arr(i, 6)
    
17.             brr(d(x), 5) = brr(d(x), 5) + arr(i, 7)
    
18.         End If
    
19.     Next
    
20.     Range("a4:e65536").ClearContents
    
21.     If n > 0 Then [a4].Resize(n, 5) = brr
    
22. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub grf()
   
2.     dz = [b1]: cj = [e1]    '地址，厂家
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 5)
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 1) = dz And arr(i, 2) = cj Then      '条件相符
   
8.             x = arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5)        '以商品名称、型号、波段为key
   
9.             If Not d.exists(x) Then
   
10.                 n = n + 1
    
11.                 d(x) = n
    
12.                 brr(n, 1) = arr(i, 3)
    
13.                 brr(n, 2) = arr(i, 4)
    
14.                 brr(n, 3) = arr(i, 5)
    
15.             End If
    
16.             brr(d(x), 4) = brr(d(x), 4) + arr(i, 6)
    
17.             brr(d(x), 5) = brr(d(x), 5) + arr(i, 7)
    
18.         End If
    
19.     Next
    
20.     Range("a4:e65536").ClearContents
    
21.     If n > 0 Then [a4].Resize(n, 5) = brr
    
22. End Sub

复制代码

sry660

1. Sub 按条件汇总()
   
2.     Dim arr, i&, j&, x, d, brr, n&, p&, Tj, crr, d1, a, drr
   
3.     Tj = Sheets(1).[b1].Value & Sheets(1).[e1].Value    '指定条件
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     arr = Sheets(2).[a1].CurrentRegion
   
7.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
8.     For i = 2 To UBound(arr)
   
9.         x = arr(i, 1) & arr(i, 2)
   
10.         If x = Tj Then
    
11.             n = n + 1
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 brr(n, j) = arr(i, j)
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     n = 0
    
18.     ReDim crr(1 To UBound(arr), 1 To 5)
    
19.     For i = 1 To UBound(brr)
    
20.         x = brr(i, 3) & brr(i, 4) & brr(i, 5)
    
21.         If Len(x) Then
    
22.             If Not d.exists(x) Then
    
23.                 n = n + 1
    
24.                 d(x) = n
    
25.                 For j = 1 To 3
    
26.                     crr(n, j) = brr(i, j + 2)
    
27.                 Next
    
28.                 crr(n, 4) = brr(i, 6): crr(n, 5) = brr(i, 7)
    
29.             Else
    
30.                 p = d(x)
    
31.                 crr(p, 4) = crr(p, 4) + brr(i, 6): crr(p, 5) = crr(p, 5) + brr(i, 7)
    
32.             End If
    
33.         End If
    
34.     Next
    
35.     For i = 1 To UBound(crr)
    
36.         x = crr(i, 1) & crr(i, 2)
    
37.         d1(x) = d1(x) + 1
    
38.     Next
    
39.     n = 0
    
40.     ReDim drr(1 To UBound(crr), 1 To 5)
    
41.     For Each a In d1.keys
    
42.         For i = 1 To UBound(crr)
    
43.             x = crr(i, 1) & crr(i, 2)
    
44.             If d1(a) > 1 And x = a Then
    
45.                 n = n + 1
    
46.                 For j = 1 To 5
    
47.                     drr(n, j) = crr(i, j)
    
48.                 Next
    
49.             End If
    
50.         Next
    
51.     Next
    
52.     With Sheets(1)
    
53.         .[a4:e100].Clear
    
54.         On Error Resume Next
    
55.         .[a4].Resize(n, 5) = drr
    
56.         .Range("a3").CurrentRegion.Borders.LineStyle = 1
    
57.     End With
    
58. End Sub

复制代码