将多个工作簿中的数据合并到一个工作簿.docx

将多个工作簿中的数据合并到一个工作簿.docx

《将多个工作簿中的数据合并到一个工作簿.docx》由会员分享，可在线阅读，更多相关《将多个工作簿中的数据合并到一个工作簿.docx（25页珍藏版）》请在冰豆网上搜索。

将多个工作簿中的数据合并到一个工作簿

将多个工作簿中的数据合并到一个工作簿

2009年05月9日,5:

00下午

 （4 人投票,平均:

 4.75 outof5）

在MSDN文档资料库中，MicrosoftOfficeExcelMVP RondeBruin提供了一些非常好的代码示例，用于将同一文件夹里的多个工作簿中某一工作表的数据合并到一个工作簿中。

下面，来介绍这些实用代码，也通过这些代码来学习VBA。

当然，您可以适当修改代码，使代码满足自已想要的功能。

查找单元格区域中的最后一个单元格、最后一行或最后一列

这是后面示例中要用到的通用代码，用来查找单元格区域中的最后一行、最后一列或最后一个单元格。

代码如下：

FunctionRDB_Last（choiceAsInteger,rngAsRange）

'选择1代表最后一行.

'选择2代表最后一列.

'选择3代表最后一个单元格.

DimlrwAsLong

DimlcolAsInteger

SelectCasechoice

Case1:

OnErrorResumeNext

RDB_Last=rng.Find（What:

="*",_

after:

=rng.Cells

（1）,_

Lookat:

=xlPart,_

LookIn:

=xlFormulas,_

SearchOrder:

=xlByRows,_

SearchDirection:

=xlPrevious,_

MatchCase:

=False）.Row

OnErrorGoTo0

Case2:

OnErrorResumeNext

RDB_Last=rng.Find（What:

="*",_

after:

=rng.Cells

（1）,_

Lookat:

=xlPart,_

LookIn:

=xlFormulas,_

SearchOrder:

=xlByColumns,_

SearchDirection:

=xlPrevious,_

MatchCase:

=False）.Column

OnErrorGoTo0

Case3:

OnErrorResumeNext

lrw=rng.Find（What:

="*",_

after:

=rng.Cells

（1）,_

Lookat:

=xlPart,_

LookIn:

=xlFormulas,_

SearchOrder:

=xlByRows,_

SearchDirection:

=xlPrevious,_

MatchCase:

=False）.Row

OnErrorGoTo0

OnErrorResumeNext

lcol=rng.Find（What:

="*",_

after:

=rng.Cells

（1）,_

Lookat:

=xlPart,_

LookIn:

=xlFormulas,_

SearchOrder:

=xlByColumns,_

SearchDirection:

=xlPrevious,_

MatchCase:

=False）.Column

OnErrorGoTo0

OnErrorResumeNext

RDB_Last=rng.Parent.Cells（lrw,lcol）.Address（False,False）

IfErr.Number>0Then

RDB_Last=rng.Cells

（1）.Address（False,False）

Err.Clear

EndIf

OnErrorGoTo0

EndSelect

EndFunction

上述函数根据参数choice的值，使用Range对象的Find方法来查找工作簿中的最后一项。

参数choice用来指定单元格、列或行。

合并文件夹中所有工作簿中的单元格区域

下面的代码合并文件夹中所有工作簿中的数据，每一工作簿中的数据被依次按行放置到目标工作表中。

SubMergeAllWorkbooks（）

DimMyPathAsString,FilesInPathAsString

DimMyFiles（）AsString

DimSourceRcountAsLong,FNumAsLong

DimmybookAsWorkbook,BaseWksAsWorksheet

DimsourceRangeAsRange,destrangeAsRange

DimrnumAsLong,CalcModeAsLong

'文件所在的文件夹路径,可修改为相应的文件夹

MyPath="C:

\Users\Ron\test"

'路径末尾是否有反斜杠,若无则添加

IfRight（MyPath,1）<>"\"Then

MyPath=MyPath&"\"

EndIf

'如果文件夹中没有Excel文件则退出

FilesInPath=Dir（MyPath&"*.xl*"）

IfFilesInPath=""Then

MsgBox"Nofilesfound"

ExitSub

EndIf

'使用文件夹中的Excel文件列表填充数组（myFiles）

FNum=0

DoWhileFilesInPath<>""

FNum=FNum+1

ReDimPreserveMyFiles（1ToFNum）

MyFiles（FNum）=FilesInPath

FilesInPath=Dir（）

Loop

'修改屏幕更新,计算模式和启用事件的状态

WithApplication

CalcMode=.Calculation

.Calculation=xlCalculationManual

.ScreenUpdating=False

.EnableEvents=False

EndWith

'创建带有一个工作表的新工作簿

SetBaseWks=Workbooks.Add（xlWBATWorksheet）.Worksheets

（1）

rnum=1

'遍历数组（myFiles）中的所有文件

IfFNum>0Then

ForFNum=LBound（MyFiles）ToUBound（MyFiles）

Setmybook=Nothing

OnErrorResumeNext

Setmybook=Workbooks.Open（MyPath&MyFiles（FNum））

OnErrorGoTo0

IfNotmybookIsNothingThen

OnErrorResumeNext

Withmybook.Worksheets

（1）

SetsourceRange=.Range（"A1:

C1"）

EndWith

IfErr.Number>0Then

Err.Clear

SetsourceRange=Nothing

Else

'如果SourceRange使用了所有的列则跳过该文件

IfsourceRange.Columns.Count>=BaseWks.Columns.CountThen

SetsourceRange=Nothing

EndIf

EndIf

OnErrorGoTo0

IfNotsourceRangeIsNothingThen

SourceRcount=sourceRange.Rows.Count

Ifrnum+SourceRcount>=BaseWks.Rows.CountThen

MsgBox"Sorrytherearenotenoughrowsinthesheet"

BaseWks.Columns.AutoFit

mybook.Closesavechanges:

=False

GoToExitTheSub

Else

'在列A中复制该文件的名称

WithsourceRange

BaseWks.Cells（rnum,"A"）._

Resize（.Rows.Count）.Value=MyFiles（FNum）

EndWith

'设置目标区域（destrange）

Setdestrange=BaseWks.Range（"B"&rnum）

'从源区域（sourceRange）复制数据到目标区域（destrange）

WithsourceRange

Setdestrange=destrange._

Resize（.Rows.Count,.Columns.Count）

EndWith

destrange.Value=sourceRange.Value

rnum=rnum+SourceRcount

EndIf

EndIf

mybook.Closesavechanges:

=False

EndIf

NextFNum

BaseWks.Columns.AutoFit

EndIf

ExitTheSub:

'恢复屏幕更新,计算模式和启用事件的状态

WithApplication

.ScreenUpdating=True

.EnableEvents=True

.Calculation=CalcMode

EndWith

EndSub

上述过程使用同一文件夹中每个工作簿的路径和名称填充数组。

然后，遍历该数组并且对于每个源文件，检查源区域和目标区域来看是否源区域中使用的列数多于目标区域可用的列数。

如果是，则跳过该工作簿文件。

接下来，代码对源区域中的行进行同样的测试。

如果检查或测试均通过，那么复制源工作簿的路径和名称到新工作簿的A列，将源工作簿文件中的值复制到目标工作簿中相应的区域，然后转到数组中的下一个工作簿文件进行处理。

该过程使用每个工作簿中的第一个工作表（索引值1）。

要使用特定的工作表，只需改变索引值或者将索引值修改为工作表名称：

Withmybook.Worksheets（"工作表名称"）

也可以将单元格区域A1：

C1修改为自已希望的数据区域：

Withmybook.Worksheets

（1）

SetsourceRange=.Range（"A1:

C1"）

EndWith

如果想从单元格A2开始一直复制到工作表中最后一个单元格，那么可以使用下述代码替换。

此时，第一行可能是标题行。

首先，在宏的顶部添加声明：

DimFirstCellAsString

然后，添加下面的代码：

Withmybook.Worksheets

（1）

FirstCell="A2"

SetsourceRange=.Range（FirstCell&":

"&RDB_Last（3,.Cells））

'测试是否最后一个单元格的行号大于或等于第一个单元格的行号

IfRDB_Last（1,.Cells）<.Range（FirstCell）.RowThen

SetsourceRange=Nothing

EndIf

EndWith

从所选择的工作簿中合并单元格区域

下面的代码合并指定的工作簿中的数据。

PrivateDeclareFunctionSetCurrentDirectoryALib_

"kernel32"（ByVallpPathNameAsString）AsLong

SubChDirNet（szPathAsString）

SetCurrentDirectoryAszPath

EndSub

SubMergeSpecificWorkbooks（）

DimMyPathAsString

DimSourceRcountAsLong,FNumAsLong

DimmybookAsWorkbook,BaseWksAsWorksheet

DimsourceRangeAsRange,destrangeAsRange

DimrnumAsLong,CalcModeAsLong

DimSaveDriveDirAsString

DimFNameAsVariant

'修改屏幕更新,计算模式和启用事件的状态

WithApplication

CalcMode=.Calculation

.Calculation=xlCalculationManual

.ScreenUpdating=False

.EnableEvents=False

EndWith

SaveDriveDir=CurDir

'修改为文件所在的文件夹的路径

ChDirNet"C:

\Users\Ron\test"

FName=Application.GetOpenFilename（filefilter:

="ExcelFiles（*.xl*）,*.xl*",_

MultiSelect:

=True）

IfIsArray（FName）Then

'创建带有一个工作表的新工作簿

SetBaseWks=Workbooks.Add（xlWBATWorksheet）.Worksheets

（1）

rnum=1

'遍历数组（myFiles）中的所有文件

ForFNum=LBound（FName）ToUBound（FName）

Setmybook=Nothing

OnErrorResumeNext

Setmybook=Workbooks.Open（FName（FNum））

OnErrorGoTo0

IfNotmybookIsNothingThen

OnErrorResumeNext

Withmybook.Worksheets

（1）

SetsourceRange=.Range（"A1:

C1"）

EndWith

IfErr.Number>0Then

Err.Clear

SetsourceRange=Nothing

Else

'如果SourceRange使用了所有的列则跳过该文件

IfsourceRange.Columns.Count>=BaseWks.Columns.CountThen

SetsourceRange=Nothing

EndIf

EndIf

OnErrorGoTo0

IfNotsourceRangeIsNothingThen

SourceRcount=sourceRange.Rows.Count

Ifrnum+SourceRcount>=BaseWks.Rows.CountThen

MsgBox"Sorrytherearenotenoughrowsinthesheet"

BaseWks.Columns.AutoFit

mybook.Closesavechanges:

=False

GoToExitTheSub

Else

'在列A中复制文件名称

WithsourceRange

BaseWks.Cells（rnum,"A"）._

Resize（.Rows.Count）.Value=FName（FNum）

EndWith

'设置目标区域（destrange）

Setdestrange=BaseWks.Range（"B"&rnum）

'从源区域（sourceRange）中复制值到目标区域（destrange）

WithsourceRange

Setdestrange=destrange._

Resize（.Rows.Count,.Columns.Count）

EndWith

destrange.Value=sourceRange.Value

rnum=rnum+SourceRcount

EndIf

EndIf

mybook.Closesavechanges:

=False

EndIf

NextFNum

BaseWks.Columns.AutoFit

EndIf

ExitTheSub:

'恢复屏幕更新,计算模式和启用事件的状态

WithApplication

.ScreenUpdating=True

.EnableEvents=True

.Calculation=CalcMode

EndWith

ChDirNetSaveDriveDir

EndSub

除了可以选择想要合并的工作簿文件外，上述代码与前面的示例介绍的代码完成相同的操作。

代码中使用了ChDirNet函数，以便设置所选文件夹的开始路径。

同样，也可以改变想合并的工作表和单元格区域。

合并多个工作簿中的单元格区域（逐列排列）

按逐列排列（水平）的方式将多个工作簿中的数据合并到目标工作簿中，使用下面的代码：

SubMergeHorizontally（）

DimMyPathAsString,FilesInPathAsString

DimMyFiles（）AsString

DimSourceCcountAsLong,FNumAsLong

DimmybookAsWorkbook,BaseWksAsWorksheet

DimsourceRangeAsRange,destrangeAsRange

DimCnumAsLong,CalcModeAsLong

'修改为文件所在的文件夹的路径

MyPath="C:

\Users\Ron\test"

'路径末尾是否有反斜杠,若无则添加

IfRight（MyPath,1）<>"\"Then

MyPath=MyPath&"\"

EndIf

'如果文件夹中没有Excel文件则退出

FilesInPath=Dir（MyPath&"*.xl*"）

IfFilesInPath=""Then

MsgBox"Nofilesfound"

ExitSub

EndIf

'使用文件夹中的Excel文件列表填充数组（myFiles）

FNum=0

DoWhileFilesInPath<>""

FNum=FNum+1

ReDimPreserveMyFiles（1ToFNum）

MyFiles（FNum）=FilesInPath

FilesInPath=Dir（）

Loop

'修改屏幕更新,计算模式和启用事件的状态

WithApplication

CalcMode=.Calculation

.Calculation=xlCalculationManual

.ScreenUpdating=False

.EnableEvents=False

EndWith

'创建带有一个工作表的新工作簿

SetBaseWks=Workbooks.Add（xlWBATWorksheet）.Worksheets

（1）

Cnum=1

'遍历数组（myFiles）中的所有文件

IfFNum>0Then

ForFNum=LBound（MyFiles）ToUBound（MyFiles）

Setmybook=Nothing

OnErrorResumeNext

Setmybook=Workbooks.Open（MyPath&MyFiles（FNum））

OnErrorGoTo0

IfNotmybookIsNothingThen

OnErrorResumeNext

SetsourceRange=mybook.Worksheets

（1）.Range（"A1:

A10"）

IfErr.Number>0Then

Err.Clear

SetsourceRange=Nothing

Else

'如果SourceRange使用了所有的行则跳过该文件

IfsourceRange.Rows.Count>=BaseWks.Rows.CountThen

SetsourceRange=Nothing

EndIf

EndIf

OnErrorGoTo0

IfNotsourceRangeIsNothingThen

SourceCcount=sourceRange.Columns.Count

IfCnum+SourceCcount>=BaseWks.Columns.CountThen

MsgBox"Sorrytherearenotenoughcolumnsinthesheet"

BaseWks.Columns.AutoFit

mybook.Closesavechanges:

=False

GoToExitTheSub

Else

'在第1行中复制该文件的名称

WithsourceRange

BaseWks.Cells（1,Cnum）._

Resize（,.Columns.Count）.Value=MyFiles（FNum）

EndWith

'设置目标单元格区域（destrange）

Setdestrange=BaseWks.Cells（2,Cnum）

'从源区域（sourceRange）复制数据到目标区域（destrange）

WithsourceRange

Setdestrange=destrange._

Resize（.Rows.Count,.Columns.Count）

EndWith

destrange.Value=sourceRange.Value

Cnum=Cnum+SourceCcount

E