如何统计EXCEL中所有工作表内的相同数据

wuliaolang

wychun214 发表于 2018-8-17 17:00
是的，特别是一些办公用品，每个部门都会用，比方笔，纸等肯定是每张表里都有，这个EXCEL最后我想统计的 ...

你47个表，最多的品种只有33个表有

wychun214

wuliaolang 发表于 2018-8-17 17:15
你47个表，最多的品种只有33个表有

恩，确实我用您给我的代码验证过了，最多的只有在33个部门表里出现过，谢谢您！能帮忙再看看能把出现的部门有哪些？数量合计？加进去吗？谢谢，老师！

wuliaolang

wychun214 发表于 2018-8-18 08:24
恩，确实我用您给我的代码验证过了，最多的只有在33个部门表里出现过，谢谢您！能帮忙再看看能把出现的部 ...

数量合计给你做了，出现部门不会做

1. Sub Test4()
   
2.     Dim Conn As Object, Rst As Object
   
3.     Dim strConn As String, strSQL As String, str$
   
4.     Dim i As Integer, PathStr As String
   
5.     Set Conn = CreateObject("ADODB.Connection")
   
6.     Set Rst = CreateObject("ADODB.Recordset")
   
7.     PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
   
8.     Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
   
9.     Case Is <= 11
   
10.         strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    
11.     Case Is >= 12
    
12.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
13.     End Select
    
14.    
    
15.     For Each st In ThisWorkbook.Sheets
    
16.     If st.Name <> "Sheet1" Then
    
17.     str = str & " union all select [材料名称(cInvName)],sum([数量(iQuantity)]) as [数量(iQuantity)]  from [" & st.Name & "$] group by [材料名称(cInvName)]"
    
18.     n = n + 1
    
19.     End If
    
20.     Next
    
21.     str = Right(str, Len(str) - 10)
    
22.     '设置SQL查询语句
    
23.     Conn.Open strConn    '打开数据库链接
    
24.     strSQL = "select top 5 [材料名称(cInvName)],count(1) as 出现的表数,sum([数量(iQuantity)]) as 数量合计 from (" & str & ") group by [材料名称(cInvName)] order by count(1) desc"
    
25.     Set Rst = Conn.Execute(strSQL)    '执行查询，并将结果输出到记录集对象
    
26.     With Sheet1.Range("a:c")
    
27.         .Cells.Clear
    
28.         For i = 0 To Rst.Fields.Count - 1    '填写标题
    
29.             .Cells(1, i + 1) = Rst.Fields(i).Name
    
30.         Next i
    
31.         .Range("A2").CopyFromRecordset Rst
    
32.         .Cells.EntireColumn.AutoFit  '自动调整列宽
    
33.         .Cells.EntireColumn.AutoFit  '自动调整列宽
    
34.     End With
    
35.     Rst.Close    '关闭数据库连接
    
36.     Conn.Close
    
37.     Set Conn = Nothing
    
38.     Set Rst = Nothing
    
39. End Sub
    

复制代码

wychun214

wuliaolang 发表于 2018-8-18 10:13
数量合计给你做了，出现部门不会做

谢谢您了！我也研究研究，再次感谢！