将多个工作簿中的数据合并到一个工作簿
(2 人投票, 平均: 4.50 out of 5)
Loading ...在MSDN文档资料库中，Microsoft Office Excel MVP Ron de Bruin提供了一些非常好的代码示例，用于将同一文件夹里的多个工作簿中某一工作表的数据合并到一个工作簿中。下面，来介绍这些实用代码，也通过这些代码来学习VBA。当然，您可以适当修改代码，使代码满足自已想要的功能。
查找单元格区域中的最后一个单元格、最后一行或最后一列
这是后面示例中要用到的通用代码，用来查找单元格区域中的最后一行、最后一列或最后一个单元格。代码如下：
Function RDB_Last(choice As Integer, rng As Range) ' 选择 1 代表最后一行. ' 选择 2 代表最后一列. ' 选择 3 代表最后一个单元格. Dim lrw As Long Dim lcol As Integer Select Case choice Case 1: On Error Resume Next RDB_Last = rng.Find(What:="*", _ after:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 Case 2: On Error Resume Next RDB_Last = rng.Find(What:="*", _ after:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 Case 3: On Error Resume Next lrw = rng.Find(What:="*", _ after:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 On Error Resume Next lcol = rng.Find(What:="*", _ after:=rng.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 On Error Resume Next RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False) If Err.Number > 0 Then RDB_Last = rng.Cells(1).Address(False, False) Err.Clear End If On Error GoTo 0 End Select End Function
上述函数根据参数choice的值，使用Range对象的Find方法来查找工作簿中的最后一项。参数choice用来指定单元格、列或行。
合并文件夹中所有工作簿中的单元格区域
下面的代码合并文件夹中所有工作簿中的数据，每一工作簿中的数据被依次按行放置到目标工作表中。
Sub MergeAllWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long '文件所在的文件夹路径,可修改为相应的文件夹 MyPath = "C:\Users\Ron\test" '路径末尾是否有反斜杠,若无则添加 If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If '如果文件夹中没有Excel文件则退出 FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If '使用文件夹中的Excel文件列表填充数组(myFiles) FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop '修改屏幕更新,计算模式和启用事件的状态 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With '创建带有一个工作表的新工作簿 Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 '遍历数组(myFiles)中的所有文件 If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else '如果SourceRange使用了所有的列则跳过该文件 If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else '在列A中复制该文件的名称 With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = MyFiles(FNum) End With '设置目标区域(destrange) Set destrange = BaseWks.Range("B" & rnum) '从源区域(sourceRange)复制数据到目标区域(destrange) With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: '恢复屏幕更新,计算模式和启用事件的状态 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub
上述过程使用同一文件夹中每个工作簿的路径和名称填充数组。然后，遍历该数组并且对于每个源文件，检查源区域和目标区域来看是否源区域中使用的列数多于目标区域可用的列数。如果是，则跳过该工作簿文件。接下来，代码对源区域中的行进行同样的测试。如果检查或测试均通过，那么复制源工作簿的路径和名称到新工作簿的A列，将源工作簿文件中的值复制到目标工作簿中相应的区域，然后转到数组中的下一个工作簿文件进行处理。
该过程使用每个工作簿中的第一个工作表（索引值1）。要使用特定的工作表，只需改变索引值或者将索引值修改为工作表名称：
With mybook.Worksheets("工作表名称")
也可以将单元格区域A1：C1修改为自已希望的数据区域：
With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With
如果想从单元格A2开始一直复制到工作表中最后一个单元格，那么可以使用下述代码替换。此时，第一行可能是标题行。
首先，在宏的顶部添加声明：
Dim FirstCell As String
然后，添加下面的代码：
With mybook.Worksheets(1) FirstCell = "A2" Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells)) '测试是否最后一个单元格的行号大于或等于第一个单元格的行号 If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then Set sourceRange = Nothing End If End With
从所选择的工作簿中合并单元格区域
下面的代码合并指定的工作簿中的数据。
Private Declare Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long Sub ChDirNet(szPath As String) SetCurrentDirectoryA szPath End Sub Sub MergeSpecificWorkbooks() Dim MyPath As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As String Dim FName As Variant '修改屏幕更新,计算模式和启用事件的状态 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With SaveDriveDir = CurDir '修改为文件所在的文件夹的路径 ChDirNet "C:\Users\Ron\test" FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _ MultiSelect:=True) If IsArray(FName) Then '创建带有一个工作表的新工作簿 Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 '遍历数组(myFiles)中的所有文件 For FNum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else '如果SourceRange使用了所有的列则跳过该文件 If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else '在列A中复制文件名称 With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = FName(FNum) End With '设置目标区域(destrange) Set destrange = BaseWks.Range("B" & rnum) '从源区域(sourceRange)中复制值到目标区域(destrange) With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: '恢复屏幕更新,计算模式和启用事件的状态 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ChDirNet SaveDriveDir End Sub
除了可以选择想要合并的工作簿文件外，上述代码与前面的示例介绍的代码完成相同的操作。代码中使用了ChDirNet函数，以便设置所选文件夹的开始路径。同样，也可以改变想合并的工作表和单元格区域。
合并多个工作簿中的单元格区域（逐列排列）
按逐列排列（水平）的方式将多个工作簿中的数据合并到目标工作簿中，使用下面的代码：
Sub MergeHorizontally() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceCcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim Cnum As Long, CalcMode As Long '修改为文件所在的文件夹的路径 MyPath = "C:\Users\Ron\test" '路径末尾是否有反斜杠,若无则添加 If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If '如果文件夹中没有Excel文件则退出 FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If '使用文件夹中的Excel文件列表填充数组(myFiles) FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop '修改屏幕更新,计算模式和启用事件的状态 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With '创建带有一个工作表的新工作簿 Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) Cnum = 1 '遍历数组(myFiles)中的所有文件 If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next Set sourceRange = mybook.Worksheets(1).Range("A1:A10") If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else '如果SourceRange使用了所有的行则跳过该文件 If sourceRange.Rows.Count >= BaseWks.Rows.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceCcount = sourceRange.Columns.Count If Cnum + SourceCcount >= BaseWks.Columns.Count Then MsgBox "Sorry there are not enough columns in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else '在第1行中复制该文件的名称 With sourceRange BaseWks.Cells(1, Cnum). _ Resize(, .Columns.Count).Value = MyFiles(FNum) End With '设置目标单元格区域(destrange) Set destrange = BaseWks.Cells(2, Cnum) '从源区域(sourceRange)复制数据到目标区域(destrange) With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value Cnum = Cnum + SourceCcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: '恢复屏幕更新,计算模式和启用事件的状态 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub
使用筛选合并文件夹中多个工作簿中的单元格区域
下面的代码合并基于筛选获取的数据：
Sub MergewithAutoFilter() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim rng As Range, SearchValue As String Dim FilterField As Integer, RangeAddress As String Dim ShName As Variant, RwCount As Long '********************************************************** '***运行该宏前修改下面的5行代码*** '********************************************************** '文件所在的文件夹路径,可修改为相应的文件夹 MyPath = "C:\Users\Ron\test" '每个工作簿中数据所在的工作表名 '如果想使用工作表名代替索引值则使用ShName = "Sheet1" '本示例中使用每个工作簿中的第一个工作表(使用了索引值) ShName = 1 '填写筛选区域: A1 是第一列的标题,G 是单元格区域中的最后一列 '筛选工作表中的所有行 '也可以使用固定的区域例如A1:G2500 RangeAddress = Range("A1:G" & Rows.Count).Address '想要筛选的字段(本示例中 1 = 列A ) FilterField = 1 '填写筛选值(如果想要相反的值则使用"<>ron") '或者使用通配符例如"*ron",代表以含有ron的单元格 '或者使用"*ron*"代表ron是单元格值的一部分 SearchValue = "ron" '********************************************************** '********************************************************** '路径末尾是否有反斜杠,若无则添加 If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If '如果文件夹中没有Excel文件则退出 FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If '使用文件夹中的Excel文件列表填充数组(myFiles) FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop '修改屏幕更新,计算模式和启用事件的状态 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With '创建带有一个工作表的新工作簿 Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 '遍历数组(myFiles)中的所有文件 If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next '设置筛选区域 With mybook.Worksheets(ShName) Set sourceRange = .Range(RangeAddress) End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing End If On Error GoTo 0 If Not sourceRange Is Nothing Then '查找BaseWks中的最后一行 rnum = RDB_Last(1, BaseWks.Cells) + 1 With sourceRange.Parent Set rng = Nothing '首先, 移除自动筛选(AutoFilter) .AutoFilterMode = False '筛选FilterField列中的单元格区域 sourceRange.AutoFilter Field:=FilterField, _ Criteria1:=SearchValue With .AutoFilter.Range '检查是否使用自动筛选后有结果 RwCount = .Columns(1).Cells. _ SpecialCells(xlCellTypeVisible).Cells.Count - 1 If RwCount = 0 Then '没有数据,仅有标题行 Else ' 设置不带有标题行的单元格区域 Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _ Offset(1, 0).SpecialCells(xlCellTypeVisible) '在列A中复制单元格区域和文件名称 If rnum + RwCount < BaseWks.Rows.Count Then BaseWks.Cells(rnum, "A").Resize(RwCount).Value _ = mybook.Name rng.Copy BaseWks.Cells(rnum, "B") End If End If End With '移除自动筛选(AutoFilter) .AutoFilterMode = False End With End If '关闭工作簿而不保存 mybook.Close savechanges:=False End If '打开下一个工作簿 Next FNum '设置新工作簿的列宽 BaseWks.Columns.AutoFit MsgBox "Look at the merge results in the new workbook after you click on OK" End If '恢复屏幕更新,计算模式和启用事件的状态 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub
更多的关于处理工作簿的情形
上文给出了四个代码示例，分别以不同的情形来处理同一文件夹中的工作簿文件。对这些示例稍作修改，能够使它们更有用，例如，如果工作簿被密码保护，那么应使用下面的语句打开工作簿：
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum), Password:="ron", _ WriteResPassword:="ron", UpdateLinks:=0)
如果工作簿中有对其它工作簿的链接，那么设置UpdateLinks:=0将避免出现是否更新链接的消息。如果想更新链接，则使用值3。
另一种情形是合并以指定名字开头的工作簿。例如，使用下面的语句查找以week开头的所有工作簿：
FilesInPath = Dir(MyPath & "week*.xl*")此外，还有合并同一文件夹中的工作簿，包括子文件夹中的工作簿的情形；以及合同每一工作簿中所有工作表的情形。
示例代码工作簿下载：
RDBMerge实用程序
RDBMerge实用程序是一个加载宏，为用户提供了合并文件夹中的工作簿到新工作簿中的友好的方式。
Excel 97-2003 加载宏下载：
Excel 2007加载宏下载：
