数据汇总

开裆裤

各位大侠请指教，我怎样才能把文件夹中的元月、2月、3月中的所有数据汇总到本表格中，同时要求以物品和型号为条件，同样的数量相加，谢谢！！！

zhaogang1960

请参考：

1. Sub ADO加字典法()
   
2.     Dim cnn As Object, rs As Object, SQL$, MyPath$, MyFile$, s$, t$
   
3.     Dim arr, brr(1 To 65530, 0 To 2), d As Object, i&, j&, m&
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     MyPath = ThisWorkbook.Path & ""
   
6.     MyFile = Dir(MyPath & "*.xls")
   
7.     Do While MyFile <> ""
   
8.         If InStr(MyFile, ThisWorkbook.Name) = 0 Then
   
9.             Set cnn = CreateObject("ADODB.Connection")
   
10.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    
11.             Set rs = cnn.OpenSchema(20)
    
12.             Do Until rs.EOF
    
13.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
14.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
15.                     If Right(s, 1) = "$" Then
    
16.                         SQL = "select * from [" & s & "] where 物品 is not null"
    
17.                         arr = cnn.Execute(SQL).GetRows
    
18.                         For i = 0 To UBound(arr, 2)
    
19.                             t = arr(0, i) & arr(1, i)
    
20.                             If Not d.Exists(t) Then
    
21.                                 m = m + 1
    
22.                                 d(t) = m
    
23.                                 For j = 0 To 2
    
24.                                     brr(m, j) = arr(j, i)
    
25.                                 Next
    
26.                             Else
    
27.                                 brr(d(t), 2) = brr(d(t), 2) + arr(2, i)
    
28.                             End If
    
29.                         Next
    
30.                     End If
    
31.                 End If
    
32.                 rs.MoveNext
    
33.             Loop
    
34.         End If
    
35.         MyFile = Dir()
    
36.     Loop
    
37.     ActiveSheet.UsedRange.Offset(1).ClearContents
    
38.     [a2].Resize(m, 3) = brr
    
39.     rs.Close
    
40.     cnn.Close
    
41.     Set rs = Nothing
    
42.     Set cnn = Nothing
    
43. End Sub
    

复制代码

zhaogang1960

请测试附件
汇总.rar (17.39 KB, 下载次数: 212)

2015-4-2 15:57 上传

点击文件名下载附件

如果能确定待汇总的工作表不超过49个，代码可以简化，即不需要字典数组等，仅用ADO即可

开裆裤

谢谢！！！！！！！！

开裆裤

先谢谢！！！！！再问一下：如果我的表再多了，公示用改吗？

zhaogang1960

开裆裤 发表于 2015-4-2 16:41
先谢谢！！！！！再问一下：如果我的表再多了，公示用改吗？

这个代码对工作表数没有限制

张雄友

zhaogang1960 发表于 2015-4-2 17:02
这个代码对工作表数没有限制

http://club.excelhome.net/thread-1196082-1-1.html

LMY123

SQL合并多薄多表Fields("TABLE_TYPE")

补充内容 (2018-8-26 11:16):
Sub ADO加字典法_合并()
    Dim cnn As Object, rs As Object, SQL$, MyPath$, MyFile$, s$, t$
    Dim arr, brr(1 To 65530, 0 To 2), d As Object, i&, j&, m&
    Set d = CreateObject("scripting.dictionary")
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Do While MyFile <> ""
        If InStr(MyFile, ThisWorkbook.Name) = 0 Then
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
            Set rs = cnn.OpenSchema(20)
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    s = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                        SQL = "select * from [" & s & "] where 物品 is not null"
                        arr = cnn.Execute(SQL).GetRows
                        For i = 0 To UBound(arr, 2)
                                m = m + 1
                                For j = 0 To 2
                                    brr(m, j) = arr(j, i)
                                Next
                        Next
                    End If
                End If
                rs.MoveNext
            Loop
        End If
        MyFile = Dir()
    Loop
    ActiveSheet.UsedRange.Offset(1).ClearContents
    [a2].Resize(m, 3) = brr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

likemn616

学习了，