新手求助：如何在一张工作表中汇总多个工作簿中数据

sallyzzy

翻了一遍论坛里的帖子，没有找到合适的方法，烦请哪位高手帮忙看一下。

我有很多张表，样式差不多，想汇总在一张excel里面，请问如何通过vba实现？麻烦教我写个代码，谢谢！

zhaogang1960

是合并数据？如果是请测试：

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$, MyPath$, MyFile$, m&, n&, t$
   
3.     Application.ScreenUpdating = False
   
4.     ActiveSheet.UsedRange.Offset(2).ClearContents
   
5.     Set cnn = CreateObject("ADODB.Connection")
   
6.     MyPath = ThisWorkbook.Path & ""
   
7.     MyFile = Dir(MyPath & "*.xlsx")
   
8.     Do While MyFile <> ""
   
9.         n = n + 1
   
10.         If n = 1 Then
    
11.             cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & MyFile
    
12.         Else
    
13.             t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
    
14.         End If
    
15.         m = m + 1
    
16.         If m > 49 Then
    
17.             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
18.             m = 1
    
19.             SQL = ""
    
20.         End If
    
21.         If Len(SQL) Then SQL = SQL & " union all "
    
22.         SQL = SQL & "select * from " & t & "[sheet1$a2:d]"
    
23.         MyFile = Dir()
    
24.     Loop
    
25.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
26.     cnn.Close
    
27.     Set cnn = Nothing
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    

复制代码

zhaogang1960

请看附件
汇总多张表.rar (46.42 KB, 下载次数: 53)

2012-11-25 19:47 上传

点击文件名下载附件

vs2010

1. Sub test()
   
2. Dim MyPath As String
   
3. Dim FileName As String
   
4. Dim wb As Workbook
   
5. Application.ScreenUpdating = False
   
6. MyPath = ThisWorkbook.Path & ""
   
7. FileName = Dir(MyPath & "*.xlsx")
   
8. While FileName <> ""
   
9. If FileName <> ThisWorkbook.Name Then
   
10.     Set wb = Workbooks.Open(MyPath & FileName)
    
11.     wbMaxRow = wb.Sheets(1).[A65535].End(xlUp).Row
    
12.     wb.Sheets(1).Range("A3:D" & wbMaxRow).Select
    
13.     thisMaxRow = ThisWorkbook.Sheets(1).[A65535].End(xlUp).Row
    
14.     Selection.Copy
    
15.     ThisWorkbook.Sheets(1).Range("A" & (thisMaxRow + 1)).PasteSpecial xlPasteAll
    
16.     wb.Close
    
17.     FileName = Dir
    
18. End If
    
19. Wend
    
20. Application.ScreenUpdating = True
    
21. End Sub

复制代码

LMY123

If Len(SQL) Then SQL = SQL & " union all "

microyip

LMY123 发表于 2018-8-23 17:45
If Len(SQL) Then SQL = SQL & " union all "

还在刷贴？厉害哦