VBA中只合并多个工作簿中的sheet1到同一个新表中

Lemon_ping

做一个命令按钮实现将多个工作簿中的sheet1内容合并到当前工作表中。




对excel vba不熟，之前参考过将“多个工作簿中数据合并到同一个工作表中”，但不会改代码。

请求各位老师帮助，万分感谢！


求助：只合并工作表1.zip (99.4 KB, 下载次数: 262)

2015-1-25 21:12 上传

点击文件名下载附件

zhaogang1960

打开复制法，速度较慢，但可以保留原表格式，请参考：

1. Sub 打开复制法()
   
2.     Dim f, l&, sh As Worksheet
   
3.     f = Application.GetOpenFilename(fileFilter:="Excel文件(*.xlsx),*.xlsx", Title:="选择Excel文件", MultiSelect:=True)
   
4.     If TypeName(f) = "Boolean" Then Exit Sub
   
5.     Application.ScreenUpdating = False
   
6.     Set sh = ActiveSheet
   
7.     sh.UsedRange.Offset(2).ClearContents
   
8.     For l = 1 To UBound(f)
   
9.         With GetObject(f(l))
   
10.             .Sheets(1).UsedRange.Offset(2).Copy sh.Range("a" & Rows.Count).End(xlUp).Offset(1)
    
11.             .Close False
    
12.          End With
    
13.     Next
    
14.     Application.ScreenUpdating = True
    
15.     MsgBox "ok"
    
16. End Sub
    

复制代码

zhaogang1960

ADO法速度较快，但仅复制数值，不保留格式，请参考：

1. Sub ADO法()
   
2.     Dim cnn As Object, SQL$, f, l&
   
3.     f = Application.GetOpenFilename(fileFilter:="Excel文件(*.xlsx),*.xlsx", Title:="选择Excel文件", MultiSelect:=True)
   
4.     If TypeName(f) = "Boolean" Then Exit Sub
   
5.     Application.ScreenUpdating = False
   
6.     Set sh = ActiveSheet
   
7.     sh.UsedRange.Offset(2).ClearContents
   
8.     For l = 1 To UBound(f)
   
9.         If l = 1 Then
   
10.             Set cnn = CreateObject("ADODB.Connection")
    
11.             cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & f(l)
    
12.             SQL = "select * from [sheet1$A2:L]"
    
13.             Range("a3").CopyFromRecordset cnn.Execute(SQL)
    
14.         Else
    
15.             SQL = "select * from [Excel 12.0;Database=" & f(l) & ";].[sheet1$A2:L]"
    
16.             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
17.         End If
    
18.     Next
    
19.     cnn.Close
    
20.     Set cnn = Nothing
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "ok"
    
23. End Sub
    

复制代码

zhaogang1960

请测试附件
求助：只合并工作表1.rar (107.92 KB, 下载次数: 918)

2015-1-25 21:41 上传

点击文件名下载附件

Lemon_ping

zhaogang1960 发表于 2015-1-25 21:41
请测试附件

非常感谢，两种方法都ok！！！

你太棒了！！

resfa

不错，学习了

sunshinegx

你好，借用了您写的代码，解决了一个大问题。但是现在我有个问题就是用ADO法中。我想将每一个工作簿的名称也粘贴过来。因为有可能有几个工作簿的同名工作表都没有数据。只有一行0.这样我就没法确定都哪个表返回的是0值。谢谢您

phipe

谢谢赵老师，学习了。

opiona

sunshinegx 发表于 2016-6-2 11:32
你好，借用了您写的代码，解决了一个大问题。但是现在我有个问题就是用ADO法中。我想将每一个工作簿的名称 ...

请参考：http://club.excelhome.net/thread-1170256-1-1.html

159753Y

zhaogang1960 发表于 2015-1-25 21:34
ADO法速度较快，但仅复制数值，不保留格式，请参考：

请问如何想合并多个工作薄（每个工作薄含有多个工作表）合并到一个新表中，代码应该怎么修改？
辛苦了，谢谢！