2009年07月11日, 2:21 下午
Loading ...
2009年05月23日, 9:46 下午
Loading ...
有许多实现Excel工作簿合并的方法，在《将多个工作簿中的数据合并到一个工作簿》中介绍过合并工作簿的示例。下面再列举几个示例，供有兴趣的朋友参考。
例如，需要将多个Excel工作簿中的工作表合并到一个工作簿。这里假设需要合并的工作簿在“D:\示例\数据记录\”文件夹中，含有两个工作簿test1.xls、test2.xls（当然，可以不限于两个），在test1.xls工作簿中含有三张工作表，在test2.xls工作簿中含有两张工作表，现在使用一段VBA代码合并这两个工作簿到一个新工作簿中，合并到新工作簿中的工作表分别以原工作簿名加索引值命名。代码如下：
Sub CombineWorkbooks()
Dim strFileName As String
Dim wb As Workbook
Dim ws As Object
'包含工作簿的文件夹,可根据实际修改
Const strFileDir As String = "D:\示例\数据记录\"
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWorksheet)
strFileName = Dir(strFileDir & "*.xls*")
Do While strFileName <> vbNullString
Dim wbOrig As Workbook
Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)
For Each ws In wbOrig.Sheets
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
If wbOrig.Sheets.Count > 1 Then
wb.Sheets(wb.Sheets.Count).Name = strFileName & ws.Index
Else
wb.Sheets(wb.Sheets.Count).Name = strFileName
End If
Next
wbOrig.Close SaveChanges:=False
strFileName = Dir
Loop
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set wb = Nothing
End Sub示例文档下载：
下面是合并多个Excel工作簿的另一种情形，也是《Excel VBA实战技巧精粹》中<技巧91：汇总多个工作簿的工作表>所介绍的方法，即合并汇总。
有四个工作簿，分别为：汇总工作簿.xls、一月.xls、二月.xls、三月.xls，其中一月.xls、二月.xls、三月.xls均只含有一张工作表且工作表中的数据均自单元格A1开始，现在要求将它们合并至“汇总工作簿.xls”中。
在“汇总工作簿.xls”中打开VBE，并输入下列代码：
Sub ConsolidateWorkbook()
Dim RangeArray() As String
Dim bk As Workbook
Dim sht As Worksheet
Dim WbCount As Integer
WbCount = Workbooks.Count
ReDim RangeArray(1 To WbCount - 1)
For Each bk In Workbooks '在所有工作簿中循环
If Not bk Is ThisWorkbook Then '非代码所在工作簿
Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表
i = i + 1
RangeArray(i) = "'[" & bk.Name & "]" & sht.Name & "'!" & _
sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
End If
Next
Worksheets(1).Range("A1").Consolidate _
RangeArray, xlSum, True, True
End Sub运行上述代码前，必须打开所有的工作簿。运行代码后，将自动汇总所有工作表中的值并将相应单元格的值求和。
示例文档下载：
下面是汇总多个工作簿的又一种情形，也是一名网友提出的问题：在同一文件夹中有多个工作簿，其中有一个用于汇总的工作簿，要求将除该汇总工作簿外的其它工作簿中的第一张工作表的数据汇总到该汇总工作簿中。代码如下：
Sub UnionWorksheets()
Application.ScreenUpdating = False
Dim lj As String
Dim dirname As String
Dim nm As String
lj = ActiveWorkbook.Path
nm = ActiveWorkbook.Name
dirname = Dir(lj & "\*.xls*")
Cells.Clear
Do While dirname <> ""
If dirname <> nm Then
Workbooks.Open Filename:=lj & "\" & dirname
Workbooks(nm).Activate
'复制新打开工作簿的第一个工作表的已用区域到当前工作表
Workbooks(dirname).Sheets(1).UsedRange.Copy _
Range("A65536").End(xlUp).Offset(1, 0)
Workbooks(dirname).Close False
End If
dirname = Dir
Loop
End Sub
2009年05月9日, 5:00 下午
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开始一直复制到工作表中最后一个单元格，那么可以使用下述代码替换。此时，第一行可能是标题行。
首先，在宏的顶部添加声明：
然后，添加下面的代码：
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加载宏下载：
(2 人投票, 平均: 4.50 out of 5)
