countifs公式通过VBA实现

庄生小虫

将countifs公式通过VBA实现：

1、将系统导出表 "测试项目"中的项目唯一值罗列在总统计表"项目名称"列;
2、将系统导出表中测试项目、预计完成时间与总统计表第二列项目名称、第二行的时间相同的数量统计出来。

chxw68

数据每天更新，统计的时候当天后面9天的数据有吗?

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr()
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("系统导出表")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:i" & r)
   
9.     End With
   
10.     For i = 1 To UBound(arr)
    
11.         Select Case arr(i, 9)
    
12.             Case "水分", "灰分", "脂肪", "蛋白质"
    
13.                 xm = arr(i, 9)
    
14.             Case Else
    
15.                 xm = "其他剩余未项目"
    
16.         End Select
    
17.         If Not d.exists(xm) Then
    
18.             m = 1
    
19.             ReDim Preserve brr(1 To 4, 1 To m)
    
20.         Else
    
21.             brr = d(xm)
    
22.             m = UBound(brr, 2) + 1
    
23.             ReDim Preserve brr(1 To 4, 1 To m)
    
24.         End If
    
25.         brr(1, m) = arr(i, 3)
    
26.         brr(2, m) = arr(i, 2)
    
27.         brr(3, m) = arr(i, 1)
    
28.         brr(4, m) = arr(i, 6)
    
29.         d(xm) = brr
    
30.     Next
    
31.     For Each aa In d.keys
    
32.         brr = d(aa)
    
33.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
34.         For i = 1 To UBound(brr)
    
35.             For j = 1 To UBound(brr, 2)
    
36.                 crr(j, i) = brr(i, j)
    
37.             Next
    
38.         Next
    
39.         On Error Resume Next
    
40.         Set ws = Worksheets(aa)
    
41.         If Err = 0 Then
    
42.             With ws
    
43.                 .Range("a5:h" & .Rows.Count).ClearContents
    
44.                 .Range("a5").Resize(UBound(crr), UBound(crr, 2)) = crr
    
45.             End With
    
46.         End If
    
47.     Next
    
48.                
    
49.             
    
50. End Sub
    

复制代码

chxw68

目标2、3的代码。

鄂龙蒙

【排单表】.rar (30.47 KB, 下载次数: 7)

2023-4-15 10:10 上传

点击文件名下载附件