[已解决]求助各项汇总？

5853195

汇总.rar (8.25 KB, 下载次数: 8)

2016-5-22 09:52 上传

点击文件名下载附件 打开工作表，启用宏，用户名：王艳，密码：518518

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-22 10:33

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 3)
   
7. w = Array("彩超", "胃镜", "肠镜", "心电", "脑电")
   
8. ww = Array("CT", "化验", "肝功", "生化", "化验委托", "摄片", "透视", "胃肠")
   
9. For i = 0 To UBound(w)
   
10.     d2(w(i) & "费") = 2
    
11. Next
    
12. For i = 0 To UBound(ww)
    
13.     d2(ww(i) & "费") = 3
    
14. Next
    
15. s = 1: brr(1, 1) = "科室"
    
16. brr(1, 2) = Join(w, "、")
    
17. brr(1, 3) = Join(ww, "、")
    
18. For i = 2 To UBound(arr)
    
19.     If d2.exists(arr(i, 2)) Then
    
20.         n = d2(arr(i, 2))
    
21.         If Not d.exists(arr(i, 1)) Then
    
22.             s = s + 1
    
23.             d(arr(i, 1)) = s
    
24.             brr(s, 1) = arr(i, 1)
    
25.             brr(s, n) = arr(i, 3)
    
26.         Else
    
27.             s2 = d(arr(i, 1))
    
28.             brr(s2, n) = brr(s2, n) + arr(i, 3)
    
29.         End If
    
30.     End If
    
31. Next
    
32. Range("g1").Resize(s, 3) = brr
    
33. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 3)
   
7. w = Array("彩超", "胃镜", "肠镜", "心电", "脑电")
   
8. ww = Array("CT", "化验", "肝功", "生化", "化验委托", "摄片", "透视", "胃肠")
   
9. For i = 0 To UBound(w)
   
10.     d2(w(i) & "费") = 2
    
11. Next
    
12. For i = 0 To UBound(ww)
    
13.     d2(ww(i) & "费") = 3
    
14. Next
    
15. s = 1: brr(1, 1) = "科室"
    
16. brr(1, 2) = Join(w, "、")
    
17. brr(1, 3) = Join(ww, "、")
    
18. For i = 2 To UBound(arr)
    
19.     If d2.exists(arr(i, 2)) Then
    
20.         n = d2(arr(i, 2))
    
21.         If Not d.exists(arr(i, 1)) Then
    
22.             s = s + 1
    
23.             d(arr(i, 1)) = s
    
24.             brr(s, 1) = arr(i, 1)
    
25.             brr(s, n) = arr(i, 3)
    
26.         Else
    
27.             s2 = d(arr(i, 1))
    
28.             brr(s2, n) = brr(s2, n) + arr(i, 3)
    
29.         End If
    
30.     End If
    
31. Next
    
32. Range("g1").Resize(s, 3) = brr
    
33. End Sub

复制代码