[已解决]用vba实现自动汇总缺席情况

cfq-xxj

用vba实现自动汇总缺席情况

最佳答案

月排行榜 / 总排行榜

dsmch

2014-8-14 12:58

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr(1 To 10000, 1 To 3)
   
4. Dim i%, j&, k%, s&, zf$$, zf1$$
   
5. [e2:h10000].ClearContents
   
6. zf = [a2] & "," & [b2] & "," & [c2]
   
7. For i = 2 To 3
   
8.     arr = Sheets(i).Range("a1").CurrentRegion
   
9.     For j = 2 To UBound(arr)
   
10.         zf1 = arr(j, 1) & "," & arr(j, 2) & "," & arr(j, 3)
    
11.         If zf = zf1 Then
    
12.             s = s + 1
    
13.             For k = 5 To 7
    
14.                 brr(s, k - 4) = arr(j, k)
    
15.             Next
    
16.         End If
    
17.     Next
    
18. Next
    
19. [e2].Resize(s, 3) = brr
    
20. [h2] = s
    
21. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr(1 To 10000, 1 To 3)
   
4. Dim i%, j&, k%, s&, zf$$, zf1$$
   
5. [e2:h10000].ClearContents
   
6. zf = [a2] & "," & [b2] & "," & [c2]
   
7. For i = 2 To 3
   
8.     arr = Sheets(i).Range("a1").CurrentRegion
   
9.     For j = 2 To UBound(arr)
   
10.         zf1 = arr(j, 1) & "," & arr(j, 2) & "," & arr(j, 3)
    
11.         If zf = zf1 Then
    
12.             s = s + 1
    
13.             For k = 5 To 7
    
14.                 brr(s, k - 4) = arr(j, k)
    
15.             Next
    
16.         End If
    
17.     Next
    
18. Next
    
19. [e2].Resize(s, 3) = brr
    
20. [h2] = s
    
21. End Sub

复制代码

dsmch

………………

cfq-xxj

太感谢了，高手呀！

cfq-xxj

能解释一下设计思路吗？
我看不懂

dsmch

1. Sub Macro1()
   
2. On Error Resume Next '容错处理
   
3. Dim arr, brr(1 To 10000, 1 To 3)
   
4. Dim i%, j&, k%, s&, zf$$, zf1$$
   
5. [e2:h10000].ClearContents '预先清空
   
6. zf = [a2] & "," & [b2] & "," & [c2] '连接字符
   
7. For i = 2 To 3 '循环工作表2、3
   
8.     arr = Sheets(i).Range("a1").CurrentRegion '赋值数组arr
   
9.     For j = 2 To UBound(arr) '循环数组
   
10.         zf1 = arr(j, 1) & "," & arr(j, 2) & "," & arr(j, 3) '第1-3列连接成字符串
    
11.         如果字符zf1和zf相同则
    
12.         If zf = zf1 Then
    
13.             s = s + 1 '计数
    
14.             For k = 5 To 7 '数组arr第5-7列赋值给数组brr
    
15.                 brr(s, k - 4) = arr(j, k)
    
16.             Next
    
17.         End If
    
18.     Next
    
19. Next
    
20. [e2].Resize(s, 3) = brr '赋值
    
21. [h2] = s
    
22. End Sub

复制代码