[已解决]多条件汇总代码优化

安全网

具体见图和附件

最佳答案

月排行榜 / 总排行榜

七彩屋

2016-4-30 22:42

多条件统计VBA代码优化430.rar (26.91 KB, 下载次数: 23)

2016-4-30 22:42 上传

点击文件名下载附件

跳转到最佳答案楼层

七彩屋

1. Sub qcw()
   
2. Application.ScreenUpdating = False
   
3. Dim brr(), i, j, m, n, r, F, W
   
4. F = False
   
5. For Each W In Workbooks
   
6.     If W.Name = "数据表.xlsm" Then
   
7.        F = True
   
8.        MsgBox "数据表工作薄已经打开"
   
9.        Exit Sub
   
10.     End If
    
11. Next W
    
12. If F = False Then
    
13. Set wb = Workbooks.Open("" & ThisWorkbook.Path & "\数据表.xlsm")
    
14. arr = wb.Sheets(1).Range("a2:g" & wb.Sheets(1).[Match(1, 0 / (A:A <> ""))])
    
15. wb.Close
    
16. r = Range("b65536").End(xlUp).Row
    
17. ReDim brr(1 To r, 1 To 2)
    
18. For i = 4 To r - 1
    
19. n = 0: m = 0
    
20.   For j = 1 To UBound(arr)
    
21.     If arr(j, 4) = Range("c2") And arr(j, 5) = Cells(i, 2) Then '
    
22.         n = arr(j, 7) + n: Y = arr(j, 7) + Y
    
23.     End If
    
24.     If arr(j, 3) = Range("d2") And arr(j, 5) = Cells(i, 2) Then '
    
25.         m = arr(j, 7) + m: Z = arr(j, 7) + Z
    
26.     End If
    
27.   Next j
    
28.   brr(i - 3, 1) = n: brr(i - 3, 2) = m
    
29. Next i
    
30. brr(r - 3, 1) = Y: brr(r - 3, 2) = Z
    
31. [c4].Resize(r, 2) = brr
    
32. End If
    
33. Application.ScreenUpdating = True
    
34. End Sub

复制代码

七彩屋

多条件统计VBA代码优化430.rar (26.91 KB, 下载次数: 23)

2016-4-30 22:42 上传

点击文件名下载附件

安全网

七彩屋 发表于 2016-4-30 22:42

谢谢！