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

Teesys · 发表于 2018-6-23 13:33

另外每个sheet表的名称都不一样有办法吗

模版.rar (94.71 KB, 下载次数: 8)

Teesys · 发表于 2018-6-23 13:46

求大佬啊在线等挺急的

Teesys · 发表于 2018-6-23 15:29

如果表名称都是sheet123好哥哥们有办法吗

opiona · 发表于 2018-6-23 15:33

Teesys · 发表于 2018-6-23 15:46

opiona 发表于 2018-6-23 15:33
http://club.excelhome.net/thread-1409141-1-1.html

谢谢大佬，用6和7显示运行时错误3706是咋回事啊

LMY123 · 发表于 2018-6-23 17:02

Sub ADO加数组()
Cells.ClearContents
tt = Timer
Dim cnn As Object, SQL$, Mypath$, MyName$, arr, brr(1 To 20000, 0 To 29), i&, j&, m&
Application.ScreenUpdating = False
Mypath = ThisWorkbook.Path & ""
MyName = Dir(Mypath & "*.xls")
Do While MyName <> ""
If InStr(MyName, ThisWorkbook.Name) = 0 Then
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.Oledb.12.0;Extended Properties='Excel 12.0;hdr=NO';Data Source=" & Mypath & MyName
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
s = Replace(rs("TABLE_NAME").Value, "'", "")
If Right(s, 1) = "$" Then
SQL = "select * from [" & s & "A8:AB20] WHERE IsNumeric(F1)=TRUE"
arr = cnn.Execute(SQL).GetRows
For i = 0 To UBound(arr, 2)
m = m + 1
For j = 0 To 27
brr(m, j + 2) = arr(j, i)
brr(m, 0) = Split(MyName, ".")(0)
brr(m, 1) = Left(s, Len(s) - 1)
Next
Next
End If
End If
rs.MoveNext
Loop
End If
MyName = Dir()
Loop
[A2].Resize(m, 30) = brr
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
End Sub

复制代码

LMY123 · 发表于 2018-6-23 17:04

Teesys 发表于 2018-6-23 13:46
求大佬啊在线等挺急的

模版.rar (138.08 KB, 下载次数: 17)

jjmysjg · 发表于 2018-6-23 17:28

LMY123 发表于 2018-6-23 17:04

A1=工作簿名
B1=工作表名
运行代码后，能在结果表上显示吗

Teesys · 发表于 2018-6-23 17:30

LMY123 发表于 2018-6-23 17:04

辛苦大神了，非常感谢！我一开始没说太明白不好意思，就是这边有很多工作簿，每个工作簿、每个sheet表的名称都不同，请问有在保留各个sheet表名称与内容的情况下，将所有sheet表放置到一个工作簿的方法吗

LMY123 · 发表于 2018-6-23 18:34

jjmysjg 发表于 2018-6-23 17:28
A1=工作簿名
B1=工作表名
运行代码后，能在结果表上显示吗

[A1]="工作簿名"
[B1]="工作表名"

		自动登录	找回密码
密码			免费注册

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