工作簿1中用VB打开另一个工作簿2，并汇总工作簿2数据到工作簿1

nihao123456789

求高手帮忙，我在excel（工作簿1）中用VB打开另一个excel（工作簿2），想查询工作簿2中的所有的sheet，要怎样做？我需要把工作簿2中所有数据（每个sheet记录数量不一）复制到工作簿1（同一个sheet中）。

Sub 111()
MyPath = ThisWorkbook.Path & "\"
MyName = "工作簿2.xlsx"
        With Workbooks.Open(MyPath & MyName）               
            '求中间语言。。。。。。。。。。。。。。。
       .Close False
        End With
End Sub

本来可以用
for eash sh in workbook
next
但是我发现没有用。


求写关键语句。语法稍微有错误无所谓。

iwangyi

跨工作簿在不打开工作簿的情况下建议釆用ADO+SQL

lsc900707

关键是没有附件，所以只看看。

nihao123456789

lsc900707 发表于 2018-8-16 16:58
关键是没有附件，所以只看看。

已经有附件了。

zjdh

Sub TEST()
    MyPath = ThisWorkbook.Path & "\"
    MyName = "工作簿2.xlsx"
    With Workbooks.Open(MyPath & MyName)
        For Each SH In .Sheets
            SH.UsedRange.Offset(1).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(2)
        Next
        .Close False
    End With
End Sub

xiangbaoan

Sub getData()
    Dim cnn As Object, rst As Object, p$, f$, Sql$, r%, c&, i%, s$
    Set cnn = CreateObject("adodb.connection")
    p = ThisWorkbook.Path & "\"
    f = "工作簿2.xlsx"
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source=" & p & f
    Set rst = cnn.OpenSchema(20)
    Do Until rst.EOF
        If rst.Fields("TABLE_TYPE") = "TABLE" Then
          s = Replace(rst("TABLE_NAME").Value, "'", "")
          If Right(s, 1) = "$"  Then
            Sql = Sql & "Union All Select 列1,列2,列3,列4,列5,列6 From [" & s & "a3:f] "
'            Sql = Sql & "Union All Select * From [" & s & "a3:f] "
          End If
        End If
        rst.MoveNext
    Loop
    rst.Close
    Sql = Mid(Sql, 11)
    Set rst = cnn.Execute(Sql)
    Dim ar, br(1 To 16888, 1 To 6), k&
    ar = rst.GetRows
    k = 0
    For c = 0 To UBound(ar, 2)
        If ar(1, c) <> "" Then
            k = k + 1
            For r = 0 To UBound(ar)
                br(k, r + 1) = ar(r, c)
            Next
        End If
    Next

    With Me
        .Cells = ""
        For i = 1 To rst.Fields.Count
            .[a3].Offset(0, i - 1) = rst.Fields(i - 1).Name
        Next
        .[a4].Resize(k, 6) = br
    End With
    cnn.Close
    Set cnn = Nothing
    Set rst = Nothing
End Sub

xiangbaoan

xiangbaoan 发表于 2018-8-16 17:47
Sub getData()
    Dim cnn As Object, rst As Object, p$, f$, Sql$, r%, c&, i%, s$
    Set cnn = Cre ...

………………又不审核了，附件…………

abc123281

代码仅供参考

1. Sub 汇总()
   
2. t = Timer
   
3. Dim cnn As Object, rs As Object
   
4. Dim sql$, mypath$, myname$
   
5. Dim ws As Worksheet
   
6. Dim arr, brr(1 To 10000, 1 To 6)
   
7. Application.ScreenUpdating = False
   
8. mypath = ThisWorkbook.Path & ""
   
9. myname = Dir(mypath & "工作簿2.xlsx")
   
10. Set wb = GetObject(mypath & myname)
    
11. With wb
    
12.    For Each ws In .Worksheets
    
13.      Set cnn = CreateObject("ADODB.Connection")
    
14.      cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;HDR=yes';Data Source=" & mypath & myname
    
15.      sql = "select * from [" & ws.Name & "$a3:f]"
    
16.      Set rs = cnn.Execute(sql)
    
17.      arr = rs.GetRows
    
18.      For i = 0 To UBound(arr, 2)
    
19.        m = m + 1
    
20.        For j = 0 To 5
    
21.          brr(m, j + 1) = arr(j, i)
    
22.        Next
    
23.      Next
    
24.   Next
    
25. End With
    
26. ThisWorkbook.Worksheets("汇总").UsedRange.Offset(1).ClearContents
    
27. [a4].Resize(m, 6) = brr
    
28. rs.Close
    
29. cnn.Close
    
30. Set rs = Nothing
    
31. Set cnn = Nothing
    
32. Application.ScreenUpdating = True
    
33. MsgBox "共用时 " & Format(Timer - t, "0.0000") & "秒", vbInformation
    
34. End Sub

复制代码

abc123281

汇总sql 123.rar (28.36 KB, 下载次数: 54)

2018-8-16 21:10 上传

点击文件名下载附件

vfp_new

zjdh 发表于 2018-8-16 17:06
Sub TEST()
    MyPath = ThisWorkbook.Path & "\"
    MyName = "工作簿2.xlsx"

大师，请教 SH.UsedRange.Offset(1).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(2) 这句最后的（2）如何理解？