怎么合并一个文件夹里的所有excel表并保留sheet表区分啊

LMY123

Teesys 发表于 2018-6-23 17:30
辛苦大神了，非常感谢！我一开始没说太明白不好意思，就是这边有很多工作簿，每个工作簿、每个sheet表的 ...

1. Sub ADO加数组() '不能保留格式
   
2.     Dim cnn As Object, rs As Object, rst As Object, s$, MyPath$, MyFile$, m&, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sh In Worksheets
   
6.         If sh.Name <> "封面" Then sh.Delete
   
7.     Next
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(MyPath & "*.xls")
   
10.     Do While MyFile <> ""
    
11.         If InStr(MyFile, ThisWorkbook.Name) = 0 Then
    
12.             Set cnn = CreateObject("ADODB.Connection")
    
13.             
    
14.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" _
    
15.             & "Data Source=" & MyPath & MyFile
    
16.             
    
17.             Set rs = cnn.OpenSchema(20)
    
18.             Do Until rs.EOF
    
19.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
20.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
21.                     If Right(s, 1) = "$" Then
    
22.                         Set rst = cnn.Execute("[" & s & "]")
    
23.                             m = m + 1
    
24.                             With Sheets.Add(After:=Sheets(m))
    
25.                                 .Name = Right(Replace(MyFile, ".xls", ""), 5) & "-" & Left(s, Len(s) - 1)
    
26.                                 For i = 1 To rst.Fields.Count
    
27.                                     .Cells(1, i) = rst.Fields(i - 1).Name
    
28.                                 Next
    
29.                                 .[a2].CopyFromRecordset rst
    
30.                             End With
    
31.                     End If
    
32.                 End If
    
33.                 rs.MoveNext
    
34.             Loop
    
35.         End If
    
36.         MyFile = Dir()
    
37.     Loop
    
38.     rs.Close
    
39.     rst.Close
    
40.     cnn.Close
    
41.     Set rs = Nothing
    
42.     Set rst = Nothing
    
43.     Set cnn = Nothing
    
44.     Application.ScreenUpdating = True
    
45. End Sub
    

复制代码

LMY123

Teesys 发表于 2018-6-23 17:30
辛苦大神了，非常感谢！我一开始没说太明白不好意思，就是这边有很多工作簿，每个工作簿、每个sheet表的 ...

模版 - 内表名等于外薄名加外表名.rar (201.9 KB, 下载次数: 33)

2018-6-23 18:49 上传

点击文件名下载附件

Teesys

LMY123 发表于 2018-6-23 18:49

谢谢LMY老师！辛苦了！！！

不知道为什么

Teesys 发表于 2018-6-23 23:14
谢谢LMY老师！辛苦了！！！

论坛感谢帮助你老师最好的方式就是给与评价和鲜花。呵呵

lsc900707

已在另一帖中解答，请参考附件。