快速计算多张工作表中同一位员工所得积分

轩宝和妙妙

各位大侠，

假设我有多张员工信息相同但最后一栏结果不同的工作表。大家可以看到每张表中的结果一栏，有的表格中显示是TRUE.有的表格中显示是FALSE.

假设员工号为S000190的员工六张表格中的结果都是TRUE, 该员工可得积分为20*6=120. 如果任何一张表中结果栏是FALSE,则需要减掉20分。

这里想麻烦大家帮忙在最后的结果汇总表中，设置一个宏，可以迅速计算出每位员工的总积分和。

附件是我填写的模拟数字，表格数量不固定，麻烦各位大侠在编写宏时，不要限定所需计算的表格的数量。

多谢！

看见星光

1. Sub dd()
   
2. Dim d As Object, arr, brr, i&, j&, k&, s$
   
3. Dim ws As Workbook, path$, dr$
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     path = ThisWorkbook.path & ""
   
7.     dr = Dir(path & "*.xls")
   
8.     ReDim brr(1 To Cells.Rows.Count, 1 To 3)
   
9.         Do While dr <> ""
   
10.             If dr <> ThisWorkbook.Name Then
    
11.                 Set ws = Workbooks.Open(path & dr)
    
12.                 arr = [a1].CurrentRegion
    
13.                 For i = 2 To UBound(arr)
    
14.                     If arr(i, 8) = "True" Then
    
15.                         n = 20
    
16.                         Else
    
17.                         n = 0
    
18.                     End If
    
19.                     If Not d.Exists(arr(i, 1)) Then
    
20.                         k = k + 1
    
21.                         d(arr(i, 1)) = k
    
22.                         brr(k, 1) = arr(i, 1)
    
23.                         brr(k, 2) = arr(i, 2)
    
24.                         brr(k, 3) = n
    
25.                         Else
    
26.                         brr(d(arr(i, 1)), 3) = brr(d(arr(i, 1)), 3) + n
    
27.                     End If
    
28.                 Next
    
29.                 ws.Close False
    
30.             End If
    
31.             dr = Dir
    
32.         Loop
    
33.         [a2].Resize(k, 3) = brr
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

看见星光

99.zip (127.07 KB, 下载次数: 21)

2015-8-12 22:02 上传

点击文件名下载附件

onlycxb

典型的字典应用

zhaogang1960

ADO法处理多工作簿查询，不需要传统意义上的打开工作簿，速度很快，下面程序仅适应不大于49个工作簿情况，如果超出49个需要修改程序：

1. Sub ADO法()
   
2.     Dim cnn As Object, rs As Object, SQL$, Mypath$, MyFile$, s$
   
3.     Mypath = ThisWorkbook.Path & ""
   
4.     MyFile = Dir(Mypath & "*.xls")
   
5.     Do While MyFile <> ""
   
6.         If MyFile <> ThisWorkbook.Name Then
   
7.             Set cnn = CreateObject("adodb.connection")
   
8.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & Mypath & MyFile
   
9.             Set rs = cnn.OpenSchema(20)
   
10.             Do Until rs.EOF
    
11.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
12.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
13.                     If Right(s, 1) = "$" Then
    
14.                         If Len(SQL) Then SQL = SQL & " union all "
    
15.                         SQL = SQL & "select 员工编码,iif(结果=true,20,0) as 结果 from [Excel 8.0;Database=" & Mypath & MyFile & "].[" & s & "]"
    
16.                         Exit Do
    
17.                     End If
    
18.                 End If
    
19.                 rs.MoveNext
    
20.             Loop
    
21.         End If
    
22.         MyFile = Dir()
    
23.     Loop
    
24.     SQL = "select 员工编码,sum(结果) as 结果 from (" & SQL & ") group by 员工编码"
    
25.     SQL = "select 结果 from [Excel 8.0;Database=" & ThisWorkbook.FullName & "].[汇总$a1:a" _
    
26.         & [a65536].End(xlUp).Row & "] a left join (" & SQL & ") b on a.员工编码=b.员工编码"
    
27.     [c2].CopyFromRecordset cnn.Execute(SQL)
    
28.     rs.Close
    
29.     cnn.Close
    
30.     Set rs = Nothing
    
31.     Set cnn = Nothing
    
32. End Sub
    
33. 
    

复制代码

zhaogang1960

请测试附件
例子.rar (108.32 KB, 下载次数: 38)

2015-8-12 22:29 上传

点击文件名下载附件

zhaogang1960

当工作表数大于49时，上面程序中的联合查询失效，可使用下面ADO加数组法：

1. Sub ADO加数组法()
   
2. tt = Timer
   
3.     Dim cnn As Object, rs As Object, SQL$, Mypath$, MyFile$, s$
   
4.     Dim arr, brr(), i&, d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Mypath = ThisWorkbook.path & ""
   
7.     MyFile = Dir(Mypath & "*.xls")
   
8.     Do While MyFile <> ""
   
9.         If MyFile <> ThisWorkbook.Name Then
   
10.             Set cnn = CreateObject("adodb.connection")
    
11.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & Mypath & MyFile
    
12.             Set rs = cnn.OpenSchema(20)
    
13.             Do Until rs.EOF
    
14.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
15.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
16.                     If Right(s, 1) = "$" Then
    
17.                         SQL = "select 员工编码,iif(结果=true,20,0) as 结果 from [" & s & "]"
    
18.                         Set rs = cnn.Execute(SQL)
    
19.                         arr = rs.GetRows
    
20.                         For i = 0 To UBound(arr, 2)
    
21.                             d(arr(0, i)) = d(arr(0, i)) + arr(1, i)
    
22.                         Next
    
23.                         Exit Do
    
24.                     End If
    
25.                 End If
    
26.                 rs.MoveNext
    
27.             Loop
    
28.         End If
    
29.         MyFile = Dir()
    
30.     Loop
    
31.     arr = Range("A2:A" & [a65536].End(xlUp).Row)
    
32.     For i = 1 To UBound(arr)
    
33.         arr(i, 1) = d(arr(i, 1))
    
34.     Next
    
35.     [c2].Resize(i - 1) = arr
    
36.     rs.Close
    
37.     cnn.Close
    
38.     Set rs = Nothing
    
39.     Set cnn = Nothing
    
40.     MsgBox Timer - tt
    
41. End Sub
    

复制代码

轩宝和妙妙

zhaogang1960 发表于 2015-8-12 22:29
请测试附件

亲， 计算结果和我想像的不一样，比如员工号为S001331, 结果应该是负值 (-20）。您能帮忙再看看吗？因为只要是FALSE，结果就是-20.得True,结果是20. 6张sheet结果汇总后，不是您表中的40.

轩宝和妙妙

看见星光 发表于 2015-8-12 22:02

亲， S000247的结果汇总和应该是-120分吧，我糊涂了..... 为什么是0呢？

zhaogang1960

轩宝和妙妙 发表于 2015-8-13 06:56
亲， 计算结果和我想像的不一样，比如员工号为S001331, 结果应该是负值 (-20）。您能帮忙再看看吗？因为 ...

iif(结果=true,20,-20) as 结果
下面附件中有ADO法和ADO加数组法 例子.rar (113.24 KB, 下载次数: 22)

2015-8-13 08:21 上传

点击文件名下载附件