闲来无事，编写了一个简单而实用的合并Excel文件的函数，能够将多个XLS文件中指定数量的工作表自动合并到一个XLS文件里。当然，如果只是数据合并，则使用ADO就可以实现，但如果要保留表格格式，则恐怕只能使用俺的方法了。
一、函数代码：
Option Explicit '* ************************************************************** * '* <a href="https://www.jb51.cc/tag/hanshu/" target="_blank" class="keywords">函数</a><a href="https://www.jb51.cc/tag/mingcheng/" target="_blank" class="keywords">名称</a>：MergeXlsFile '* <a href="https://www.jb51.cc/tag/gongneng/" target="_blank" class="keywords">功能</a>：<a href="https://www.jb51.cc/tag/zidong/" target="_blank" class="keywords">自动</a>合并指定路径下的所有XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>到<a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a><a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>中 '* 参数说明：strPath：需要合并的XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>所在路径。 '* SheetCount：需要合并的单个工作簿中工作表<a href="https://www.jb51.cc/tag/shuliang/" target="_blank" class="keywords">数量</a> '* 作者：lyserver '* 联系方式：http://blog.csdn.net/lyserver '* ************************************************************** * Public Function MergeXlsFile(ByVal strPath As String,Optional ByVal SheetCount As Byte = 1) As Boolean Dim i As Integer Dim strSrcFile As String Dim nRows As Long,nCols As Long,nSheets As Byte,nNewRows() As Integer Dim xlApp As Object,xlSrcBook As Object,xlNewBook As Object,xlSheet As Object,xlRange As Object On Error Resume Next If Right(strPath,1) <> "/" Then strPath = strPath & "/" '如果需要合并<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>中的工作表<a href="https://www.jb51.cc/tag/shuliang/" target="_blank" class="keywords">数量</a>小于1则<a href="https://www.jb51.cc/tag/tuichu/" target="_blank" class="keywords">退出</a> If SheetCount < 1 Then Exit Function '<a href="https://www.jb51.cc/tag/shanchu/" target="_blank" class="keywords">删除</a>掉该路径下原来的合并<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> If Dir(strPath & "合并后的<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>.xls") <> "" Then Kill strPath & "合并后的<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>.xls" '获得第1个XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> strSrcFile = Dir(strPath & "*.xls") '如果<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>不存在则<a href="https://www.jb51.cc/tag/tuichu/" target="_blank" class="keywords">退出</a> If Len(strSrcFile) = 0 Then Exit Function '创建<a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>Excel实例 Set xlApp = CreateObject("Excel.Application") '新建<a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>工作簿 Set xlNewBook = xlApp.Workbooks.Add '调整新建工作簿里工作表的<a href="https://www.jb51.cc/tag/shuliang/" target="_blank" class="keywords">数量</a> ReDim nNewRows(1 To SheetCount) For i = 1 To SheetCount - xlNewBook.Sheets.Count xlNewBook.Sheets.Add,xlNewBook.Sheets(xlNewBook.Sheets.Count) Next '循环查找当前路径下的所有XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> Do '打开找到的XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> Set xlSrcBook = xlApp.Workbooks.Open(strPath & strSrcFile) '循环复制源XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>里的工作表 nSheets = IIf(xlSrcBook.Sheets.Count < SheetCount,xlSrcBook.Sheets.Count,SheetCount) For i = 1 To nSheets Set xlSheet = xlSrcBook.Sheets(i) '获得源XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>中第i个工作表实际数据的行列数 nRows = xlSheet.UsedRange.Rows.Count nCols = xlSheet.UsedRange.Columns.Count '使用范围对象粘贴源XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>数据到合并结果<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>中 Set xlRange = xlSheet.Range(xlSheet.Cells(1,1),xlSheet.Cells(nRows,nCols)) xlRange.Select xlRange.<a href="https://www.jb51.cc/tag/cop/" target="_blank" class="keywords">cop</a>y xlNewBook.Sheets(i).Cells(nNewRows(i) + 1,1).PasteSpecial &HFFFFEFF8 '保存合并结果<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>中第i个工作表的行数 nNewRows(i) = xlNewBook.Sheets(1).UsedRange.Rows.Count Next '<a href="https://www.jb51.cc/tag/guanbi/" target="_blank" class="keywords">关闭</a>打开的源XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> xlSrcBook.Close '继续查找下<a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>XLS<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> strSrcFile = Dir() Loop Until Len(strSrcFile) = 0 '保存并<a href="https://www.jb51.cc/tag/guanbi/" target="_blank" class="keywords">关闭</a>合并结果<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> xlNewBook.SaveAs strPath & "合并后的<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a>.xls" xlNewBook.Close '<a href="https://www.jb51.cc/tag/tuichu/" target="_blank" class="keywords">退出</a>Excel实例 xlApp.Quit '释放资源 Erase nNewRows Set xlRange = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> Set xlSheet = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> Set xlNewBook = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> Set xlSrcBook = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> If Err.Number = 0 Then MergeXlsFile = True End Function
二、调用方法：
Sub main() If MergeXlsFile("c:/temp",1) Then Msg<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a> "数据已成功合并!",vb<a href="https://www.jb51.cc/tag/informat/" target="_blank" class="keywords">informat</a>ion,"<a href="https://www.jb51.cc/tag/tishi/" target="_blank" class="keywords">提示</a>" Else Msg<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a> "数据合并失败!",vbCritical,"<a href="https://www.jb51.cc/tag/tishi/" target="_blank" class="keywords">提示</a>" End If End Sub
