多工作簿多工作表数据查询

ida1030

从论坛里已经下载了类似这个 测试1.rar (21.35 KB, 下载次数: 5)

2018-8-8 10:33 上传

点击文件名下载附件

但是想修改成这样 测试2.rar (17.75 KB, 下载次数: 6)

2018-8-8 10:33 上传

点击文件名下载附件

办公室电脑EXCEL03版，麻烦各位帮忙看一下，帮忙改一下，谢谢！！！

LMY123

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

ida1030

LMY123 发表于 2018-8-8 11:22
http://club.excelhome.net/thread-1195938-1-1.html

不是要汇总，是想要全部列出来，麻烦可以找一下例子吗？？

LMY123

ida1030 发表于 2018-8-8 15:19
不是要汇总，是想要全部列出来，麻烦可以找一下例子吗？？

去掉字典，就变成合并了，而非汇总了

ida1030

LMY123 发表于 2018-8-8 15:24
去掉字典，就变成合并了，而非汇总了

不好意思，麻烦你问具体写一下是删除或者修改哪条呢


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)
                            t = arr(0, i) & arr(1, i)
                            If Not d.Exists(t) Then
                                m = m + 1
                                d(t) = m
                                For j = 0 To 2
                                    brr(m, j) = arr(j, i)
                                Next
                            Else
                                brr(d(t), 2) = brr(d(t), 2) + arr(2, i)
                            End If
                        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

ida1030

LMY123 发表于 2018-8-8 15:24
去掉字典，就变成合并了，而非汇总了

不好意思，麻烦你问具体写一下是删除或者修改哪条呢

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
    

复制代码