多个工作簿的表合并到一个工作簿中多张表 表名=工作簿名

autumnalRain

1. Sub Sql复制()
   
2. Set Cnn = CreateObject("adodb.connection")
   
3.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
4.     Do While Filename <> ""
   
5.       If Filename <> ThisWorkbook.Name Then
   
6.         SHEETNAME = Split(Filename, ".")(0)
   
7.         ThisWorkbook.Worksheets.Add.Name = SHEETNAME
   
8.         Cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=NO;imex=1';Data Source=" & ThisWorkbook.Path & "" & Filename
   
9.         Sql = "select * from  [sheet1$]"
   
10.         Sheets(SHEETNAME).[a65536].End(3).CopyFromRecordset Cnn.Execute(Sql)
    
11.         Cnn.Close
    
12.       End If
    
13.         Filename = Dir
    
14.     Loop
    
15.     Set Cnn = Nothing
    
16. End Sub

复制代码

有多少列就复制多少列，只需要把F1,F2改成*就可以了。至于每次执行时先删除除汇总表以外的工作表，见下面

autumnalRain

1. Sub DELETESHEETS()
   
2. Dim SH As Worksheet
   
3. Application.DisplayAlerts = False
   
4. For Each SH In Sheets
   
5.     If SH.Name <> "汇总" Then
   
6.        SH.Delete
   
7.     End If
   
8. Next
   
9. Application.DisplayAlerts = False
   
10. End Sub

复制代码

autumnalRain

1. Call DELETESHEETS

复制代码

把这句加到第一个程序的最上面；或者你可分步执行，

autumnalRain

如果想适用性更强一些，再加入一个判断，当工作表中只有一个时，肯定就是汇总表了，那就退出程序，否则执行删除其它表格

1. 
   
2. Sub DELETESHEETS()
   
3. DIM n  As Integer
   
4. Dim SH As Worksheet
   
5. Application.DisplayAlerts = False
   
6. n = Sheets.Count
   
7. If n = 1 Then
   
8. Exit Sub
   
9. Else
   
10. For Each SH In Sheets
    
11.     If SH.Name <> "汇总" Then
    
12.        SH.Delete
    
13.     End If
    
14. Next
    
15. End If
    
16. Application.DisplayAlerts = False
    
17. End Sub

复制代码

501888521

朱荣兴 发表于 2015-11-5 20:56
很影响吗？

是的 因为毕竟是公司使用，每次都生成一个多余的空表会有些影响。
能麻烦您帮忙修改一下吗？ 谢谢 其他的都很完美 就差这里了。

501888521

朱荣兴 发表于 2015-11-6 18:03
简单加几句代码即可

sh.Delete
谢谢，不过在这一步的时候会提示 错误 如图片

LMY123

留步学习,感谢帮助

补充内容 (2017-10-6 12:24):
SQL和字典，多薄一表合并成一薄多表，合并的的表名等于原工作薄名