在Excel里，如果需要把多个工作表或者工作簿的数据合并到一起，用VBA来做一个程序还是比较容易的，在多个工作簿合并到一个工作簿和多个工作表合并到一个工作表里有过介绍，代码不算很复杂。
如果能保证列的一致性，使用ADO合并也是可以的。
合并主要是要用到union all关键字，如果是合并一个工作簿的工作表，sql语句是比较好写的。如果是是多个工作簿数据源的时候，sql语句的用法:
代码语言：javascript复制[Excel 12.0;Database=" & Workbook.FullName & ";].[" & Sheet.Name & "$]代码的核心就是构建出sql语句，首先遍历一个文件夹，获取到需要处理的Excel文件名称，然后按上面的语法构建sql语句，最后调用ado执行就可以了：
代码语言：javascript复制Sub UnionAll()
Dim strsql As String
strsql = UnionAllExcelSQL(ThisWorkbook.path & "unionall", "Sheet1")
If VBA.Len(strsql) = 0 Then Exit Sub
Dim AdoConn As Object
Set AdoConn = VBA.CreateObject("ADODB.Connection")
'打开数据库
AdoConn.Open "Provider =Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.fullname & ";Extended Properties=""Excel 12.0;HDR=YES"";"
Dim rst As Object
Set rst = VBA.CreateObject("ADODB.Recordset")
Set rst = AdoConn.Execute(strsql, , 1)
'输出标题
Dim i As Long
For i = 0 To rst.Fields.Count - 1
Range("A1").Offset(0, i).Value = rst.Fields(i).name
Next
'输出数据
Range("A2").CopyFromRecordset rst
rst.Close
AdoConn.Close
Set rst = Nothing
Set AdoConn = Nothing
End Sub
Function UnionAllExcelSQL(path As String, shtname As String) As String
Dim RetDirs() As String, RetFiles() As String
If ScanDir(path, RetDirs, RetFiles) = -1 Then
UnionAllExcelSQL = ""
Exit Function
End If
Dim i As Long
For i = 0 To UBound(RetFiles)
'[Excel 12.0;Database=" & ThisWorkbook.FullName & ";].[" & ActiveSheet.Name & "$]
RetFiles(i) = "select *, '" & GetFileName(RetFiles(i)) & "' as wkname from [Excel 12.0;Database=" & RetFiles(i) & ";].[" & shtname & "$]"
Next
UnionAllExcelSQL = VBA.Join(RetFiles, " union all ")
End Function
'获取文件名称
Function GetFileName(fullname As String) As String
Dim i As Long
i = VBA.InStrRev(fullname, "")
If i Then
GetFileName = VBA.Mid$(fullname, i 1)
End If
End Function
Function ScanDir(str_dir As String, RetDirs() As String, RetFiles() As String) As Long
Dim fso As Object
Dim file As Object
Dim folder As Object, SubDir As Object
Dim k As Long
On Error GoTo err_handle
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.Getfolder(str_dir)
If folder.Subfolders.Count Then
ReDim Preserve RetDirs(folder.Subfolders.Count - 1) As String
k = 0
For Each SubDir In folder.Subfolders
RetDirs(k) = SubDir.path
k = k 1
Next
End If
If folder.Files.Count Then
ReDim Preserve RetFiles(folder.Files.Count - 1) As String
k = 0
For Each file In folder.Files
RetFiles(k) = file.path
k = k 1
Next
End If
ScanDir = k
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
Set SubDir = Nothing
Exit Function
err_handle:
ScanDir = -1
MsgBox Err.Description
End Function测试：
首先我创建了一个00.xlsx文件，写入了10000行、3列数据，然后复制了另外49个：
代码语言：javascript复制Sub CopyWk()
Dim i As Long
For i = 1 To 49
VBA.FileCopy ThisWorkbook.path & "unionall 0.xlsx", ThisWorkbook.path & "unionall" & VBA.Format(i, "00") & ".xlsx"
Next
End Sub在我电脑上进行了如下测试：
大于50个文件之后，提示：
我首先想到可能是sql语句太长了，于是把程序文件和测试文件夹unionall放到了E盘根目录，这样至少路径短了，sql语句也就短了，测试结果仍然是不能超过50个！
具体原因还不知道！如果有清楚的请指点一下。
另外在我电脑测试，普通的vba逐个打开工作簿，复制单元格内容的程序竟然比调用ado要快！这个倒是始料未及啊？
