多个excel工作表文件，汇总到一个工作簿里面？
发布网友
发布时间：2022-03-03 03:13
共1个回答
热心网友
时间：2022-03-03 04:42
Option Explicit
Sub test()
Dim Cn As Object, Rs As Object, Ca As Object, Tb As Object, d As Object, p$, f$, s$(2), Sq$, i&, j&, k&
Cells.ClearContents
Application.ScreenUpdating = False
If Application.Version < 12 Then
s(0) = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
s(1) = "Excel 8.0;Database="
Else
s(0) = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
s(1) = "Excel 12.0;Database="
End If
Set Cn = CreateObject("ADODB.Connection")
Cn.Open s(0) & ThisWorkbook.FullName
Set Ca = CreateObject("ADOX.Catalog")
Set d = CreateObject("Scripting.Dictionary")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
''''''''''''''''''''''''''''''''''''''''''''''
Ca.ActiveConnection = s(0) & p & f
For Each Tb In Ca.Tables
If Tb.Type = "TABLE" Then
s(2) = Replace(Tb.Name, "'", "")
If Right(s(2), 1) = "$" Then
k = k + 1
Sq = "SELECT * FROM [" & s(1) & p & f & "].[" & s(2) & "]"
d(Sq) = ""
' Exit For
End If
End If
Next
If k Mod 49 = 0 Then
i = i + 1
Sq = Join(d.Keys, " UNION ALL ")
d.RemoveAll
Set Rs = Cn.Execute(Sq)
If i = 1 Then
For j = 0 To Rs.Fields.Count - 1
Range("A1").Offset(0, j) = Rs.Fields(j).Name
Next
End If
Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
End If
End If
f = Dir
Loop
If d.Count > 0 Then
Sq = Join(d.Keys, " UNION ALL ")
Set Rs = Cn.Execute(Sq)
If i = 0 Then
For j = 0 To Rs.Fields.Count - 1
Range("A1").Offset(0, j) = Rs.Fields(j).Name
Next
End If
Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
End If
Cn.Close
Set Cn = Nothing
Set Rs = Nothing
Set Ca = Nothing
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!",
End Sub
