如何用VB實現Excel文件的自動合併

簡單而實用的合併Excel文件的函數，能夠將多個XLS文件中指定數量的工作表自動合併到一個XLS文件裏。當然，如果只是數據合併，則使用ADO就可以實現，但如果要保留表格格式，則恐怕只能使用俺的方法了。

    一、函數代碼：

Option Explicit '* ************************************************************** * '* 函數名稱：MergeXlsFile '* 功能：自動合併指定路徑下的所有XLS文件到一個文件中 '* 參數說明：strPath：需要合併的XLS文件所在路徑。 '* SheetCount：需要合併的單個工作簿中工作表數量 '* 作者：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 & "/" '如果需要合併文件中的工作表數量小於1則退出 If SheetCount < 1 Then Exit Function '刪除掉該路徑下原來的合併文件 If Dir(strPath & "合併後的文件.xls") <> "" Then Kill strPath & "合併後的文件.xls" '獲得第1個XLS文件 strSrcFile = Dir(strPath & "*.xls") '如果文件不存在則退出 If Len(strSrcFile) = 0 Then Exit Function '創建一個Excel實例 Set xlApp = CreateObject("Excel.Application") '新建一個工作簿 Set xlNewBook = xlApp.Workbooks.Add '調整新建工作簿裏工作表的數量 ReDim nNewRows(1 To SheetCount) For i = 1 To SheetCount - xlNewBook.Sheets.Count xlNewBook.Sheets.Add , xlNewBook.Sheets(xlNewBook.Sheets.Count) Next '循環查找當前路徑下的所有XLS文件 Do '打開找到的XLS文件 Set xlSrcBook = xlApp.Workbooks.Open(strPath & strSrcFile) '循環複製源XLS文件裏的工作表 nSheets = IIf(xlSrcBook.Sheets.Count < SheetCount, xlSrcBook.Sheets.Count, SheetCount) For i = 1 To nSheets Set xlSheet = xlSrcBook.Sheets(i) '獲得源XLS文件中第i個工作表實際數據的行列數 nRows = xlSheet.UsedRange.Rows.Count nCols = xlSheet.UsedRange.Columns.Count '使用範圍對象粘貼源XLS文件數據到合併結果文件中 Set xlRange = xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(nRows, nCols)) xlRange.Select xlRange.Copy xlNewBook.Sheets(i).Cells(nNewRows(i) + 1, 1).PasteSpecial &HFFFFEFF8 '保存合併結果文件中第i個工作表的行數 nNewRows(i) = xlNewBook.Sheets(1).UsedRange.Rows.Count Next '關閉打開的源XLS文件 xlSrcBook.Close '繼續查找下一個XLS文件 strSrcFile = Dir() Loop Until Len(strSrcFile) = 0 '保存並關閉合並結果文件 xlNewBook.SaveAs strPath & "合併後的文件.xls" xlNewBook.Close '退出Excel實例 xlApp.Quit '釋放資源 Erase nNewRows Set xlRange = Nothing Set xlSheet = Nothing Set xlNewBook = Nothing Set xlSrcBook = Nothing If Err.Number = 0 Then MergeXlsFile = True End Function

    二、調用方法：

Sub main() If MergeXlsFile("c:/temp", 1) Then MsgBox "數據已成功合併!", vbInformation, "提示" Else MsgBox "數據合併失敗!", vbCritical, "提示" End If End Sub

Link:http://blog.csdn.net/lyserver/archive/2009/05/14/4180867.aspx