1如何合并多个excel文件.docx
《1如何合并多个excel文件.docx》由会员分享，可在线阅读，更多相关《1如何合并多个excel文件.docx（14页珍藏版）》请在冰豆网上搜索。
1如何合并多个excel文件
如何合并多个excel文件！
有一个文件夹下有很多个excel文件，每个excel里面只有一个表。
怎么将这些表合并到一个EXCEL文件中
常见问题,执行下面的宏
Subhuizhong（）
DimfdAsFileDialog
DimWbookAsWorkbook
DimrowindexAsInteger
Setfd=Application.FileDialog（msoFileDialogFilePicker）
DimvrtSelectedItemAsVariant
Withfd
.Filters.Add"EXCEL文件","*.xls",1'过滤
If.Show=-1Then
rowindex=1
ForEachvrtSelectedItemIn.SelectedItems
SetWbook=Workbooks.Open（vrtSelectedItem）
subrowindex=1'每个表从第一行开始
DoWhileWbook.Worksheets（"Sheet1"）.Cells（subrowindex,1）<>""
'假设被汇总的excel文件名为"综合表",表名为sheet1.
Workbooks（"综合表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,1）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,1）.Value'以下是对每一行进行赋值
Workbooks（"综合表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,2）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,2）.Value
subrowindex=subrowindex+1
rowindex=rowindex+1
Loop
Wbook.Close
NextvrtSelectedItem
Else
EndIf
EndWith
Setfd=Nothing
EndSub
运行后再选择要合并的文档，
Subaa（）
DimfdAsFileDialog
DimWbookAsWorkbook
DimrowindexAsInteger
Setfd=Application.FileDialog（msoFileDialogFilePicker）
DimvrtSelectedItemAsVariant
Withfd
.Filters.Add"EXCEL文件","*.xls",1'过滤
If.Show=-1Then
rowindex=1
ForEachvrtSelectedItemIn.SelectedItems
SetWbook=Workbooks.Open（vrtSelectedItem）
subrowindex=1'每个表从第一行开始
DoWhileWbook.Worksheets（"Sheet1"）.Cells（subrowindex,1）<>""
'假设被汇总的excel文件名为"新建MicrosoftExcel工作表",表名为sheet1.
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,1）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,1）.Value'以下是对每一行进行赋值
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,2）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,2）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,3）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,3）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,4）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,4）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,5）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,5）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,6）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,6）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,7）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,7）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,8）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,8）.Value
Workbooks（"新建MicrosoftExcel工作表.xls"）.Worksheets（"Sheet1"）.Cells（rowindex,9）=Wbook.Worksheets（"Sheet1"）.Cells（subrowindex,9）.Value
subrowindex=subrowindex+1
rowindex=rowindex+1
Loop
Wbook.Close
NextvrtSelectedItem
Else
EndIf
EndWith
Setfd=Nothing
EndSub
通过VBA宏合并Excel工作表
今天火车票到手，最重要的事情搞定啦，庆祝一下~
昨天跟盼盼说要写一篇她看得懂的，小路从来都是言而有信的人~想了半天，对于Excel，我只会玩宏，所以有了这一篇日志~
咳咳，切入正题。
工作中经常会用到的把几个Excel文件合并到一个，或者是把一个Excel文件里的所有Sheet合并到一个Sheet来进行统计。
下面分别提供用vba宏来解决这两个问题的方法~
1.合并Excel文件
打开一个空Excel文件，Alt+F11，插入一个模块，开始写代码吧：
查看源码
打印关于
SubMergeWorkbooks（）
DimFileSet
DimiAsInteger
OnErrorGoTo0
Application.ScreenUpdating=False
FileSet=Application.GetOpenFilename（FileFilter:
="Excel2003（*.xls）,*.xls,Excel2007（*.xlsx）,*.xlsx",_
MultiSelect:
=True,Title:
="选择要合并的文件"）
IfTypeName（FileSet）="Boolean"Then
GoToExitSub
EndIf
ForEachFilenameInFileSet
Workbooks.OpenFilename
Sheets（）.MoveAfter:
=ThisWorkbook.Sheets（ThisWorkbook.Sheets.Count）
Next
ExitSub:
Application.ScreenUpdating=True
EndSub
这段代码在干嘛？
它首先打开一个文件选择框，你可以选择一个或多个文件，然后把这些文件里的所有Sheet合并到当前这个工作簿里来，有重名的Sheet会自动在后面加数字。
嗯，接下来可以进行第二歩鸟~
2.合并工作表
同上，再添加一个模块吧，代码如下
查看源码
打印关于
FunctionLastRow（shAsWorksheet）
OnErrorResumeNext
LastRow=sh.Cells.Find（what:
="*",_
After:
=sh.Range（"A1"）,_
Lookat:
=xlPart,_
LookIn:
=xlFormulas,_
SearchOrder:
=xlByRows,_
SearchDirection:
=xlPrevious,_
MatchCase:
=False）.Row
OnErrorGoTo0
EndFunction
SubMergeSheets（）
DimshAsWorksheet
DimDestShAsWorksheet
DimLastAsLong
DimshLastAsLong
DimCopyRngAsRange
DimStartRowAsLong
Application.ScreenUpdating=False
Application.EnableEvents=False
'新建一个“汇总”工作表
Application.DisplayAlerts=False
OnErrorResumeNext
ActiveWorkbook.Worksheets（"汇总"）.Delete
OnErrorGoTo0
Application.DisplayAlerts=True
SetDestSh=ActiveWorkbook.Worksheets.Add
DestSh.Name="汇总"
'开始复制的行号，忽略表头，无表头请设置成1
StartRow=2
ForEachshInActiveWorkbook.Worksheets
Ifsh.Name<>DestSh.NameThen
Last=LastRow（DestSh）
shLast=LastRow（sh）
IfshLast>0AndshLast>=StartRowThen
SetCopyRng=sh.Range（sh.Rows（StartRow）,sh.Rows（shLast））
IfLast+CopyRng.Rows.Count>DestSh.Rows.CountThen
MsgBox"内容太多放不下啦！
"
GoToExitSub
EndIf
CopyRng.Copy
WithDestSh.Cells（Last+1,"A"）
.PasteSpecialxlPasteValues
.PasteSpecialxlPasteFormats
Application.CutCopyMode=False
EndWith
EndIf
EndIf
Next
ExitSub:
Application.GoToDestSh.Cells
（1）
DestSh.Columns.AutoFit
Application.ScreenUpdating=True
Application.EnableEvents=True
EndSub
这一大坨又在干嘛？
它会新建一个叫做“汇总”的工作表，然后把当前工作簿里的所有Sheet里有数据的内容都复制到“汇总”表里。
提示：
如果数据表里的内容没有表头的话需要把StartRow=2改成StartRow=1哦。
Alt+F11插入一个模块，先运行MergeWorkbooks,再运行MergeSheets.可解决每个Excel表中sheet1的命名是不一样时的情况。
SubMergeWorkbooks（）
DimFileSet
DimiAsInteger
OnErrorGoTo0
Application.ScreenUpdating=False
FileSet=Application.GetOpenFilename（FileFilter:
="Excel2003（*.xls）,*.xls,Excel2007（*.xlsx）,*.xlsx",_
MultiSelect:
=True,Title:
="选择要合并的文件"）
IfTypeName（FileSet）="Boolean"Then
GoToExitSub
EndIf
ForEachFilenameInFileSet
Workbooks.OpenFilename
Sheets（）.MoveAfter:
=ThisWorkbook.Sheets（ThisWorkbook.Sheets.Count）
Next
ExitSub:
Application.ScreenUpdating=True
EndSub
FunctionLastRow（shAsWorksheet）
OnErrorResumeNext
LastRow=sh.Cells.Find（what:
="*",_
After:
=sh.Range（"A1"）,_
Lookat:
=xlPart,_
LookIn:
=xlFormulas,_
SearchOrder:
=xlByRows,_
SearchDirection:
=xlPrevious,_
MatchCase:
=False）.Row
OnErrorGoTo0
EndFunction
SubMergeSheets（）
DimshAsWorksheet
DimDestShAsWorksheet
DimLastAsLong
DimshLastAsLong
DimCopyRngAsRange
DimStartRowAsLong
Application.ScreenUpdating=False
Application.EnableEvents=False
'新建一个"汇总"工作表
Application.DisplayAlerts=False
OnErrorResumeNext
ActiveWorkbook.Worksheets（"汇总"）.Delete
OnErrorGoTo0
Application.DisplayAlerts=True
SetDestSh=ActiveWorkbook.Worksheets.Add
DestSh.Name="汇总"
'开始复制的行号，忽略表头，无表头请设置成1
StartRow=2
ForEachshInActiveWorkbook.Worksheets
Ifsh.Name<>DestSh.NameThen
Last=LastRow（DestSh）
shLast=LastRow（sh）
IfshLast>0AndshLast>=StartRowThen
SetCopyRng=sh.Range（sh.Rows（StartRow）,sh.Rows（shLast））
IfLast+CopyRng.Rows.Count>DestSh.Rows.CountThen
MsgBox"内容太多放不下啦！
"
GoToExitSub
EndIf
CopyRng.Copy
WithDestSh.Cells（Last+1,"A"）
.PasteSpecialxlPasteValues
.PasteSpecialxlPasteFormats
Application.CutCopyMode=False
EndWith
EndIf
EndIf
Next
ExitSub:
Application.GoToDestSh.Cells
（1）
DestSh.Columns.AutoFit
Application.ScreenUpdating=True
Application.EnableEvents=True
EndSub
PublicSubdata_entry（）
'Macrorecorded12/26/2007bycn0k0710
DimiAsInteger'获取的数据的最后行号
Dimi1AsInteger'汇总的文件的空白行号
Dimi2AsInteger'打开的文件个数
DimFnameAsString'文件的名称
DimSnameAsString'表格页的名称
DimuserfilenameAsString
DimWBAsWorkbook
DimcountAsInteger'用户名列表和行号，循环查询时用
DimCount1AsInteger'用户名工作表名称，循环查询时用
DimSumsheetsAsInteger'工作表的数量
Dimname2AsString'test
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'通过名城列表获取文件名，容易和sc2文件夹中的文件名不一致
'Forcount=6To7'4to17人员列表
'Fname=Range（"C"&count）.Value
'IfFname=""Then
'wb.Close
'GoToErrorHandler
'EndIf
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'通过手动录入获取文件名
'Fname=Application.InputBox（"EnteraFname"）
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheet1.Select
Range（"B2:
I1000"）.Select
Selection.Value=""
FileToOpen=Application.GetOpenFilename（"ExcelFiles（*.xls）,*.xls",,"Pleaseselectthefiles...",,True）
IfIsArray（FileToOpen）=0Then
'MsgBox"没有选择文件"
MsgBox"Nofilesareselected!
"
ExitSub
EndIf
Fori2=1ToUBound（FileToOpen）
'Openaworksheet
'GoOn:
userfilename=FileToOpen（i2）
SetWB=Workbooks.Open（userfilename）
userfilename=WB.name
Fname=GetUserName（userfilename）
IfFname=""Then
WB.Close
GoToErrorHandler
EndIf
'Workbooks.Openfilename:
="D:
\DailyWork\performanceappraisal\SC2\"&Fname&".xls"'打开文件
Windows（userfilename）.Activate
Sheets（"Projectreport"）.Select
i=ERow（）-1'查找最后的非空行
'Range（"C2:
D"&i）.Select
'Selection.NumberFormat="yyyy/mm/dd;@"
Range（"B2:
I"&i）.Copy
WB.Close
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheet1.Activate
i1=ERow（）'查找空白行号
Range（"B"&i1&":
I"&i1+i-2）.Activate
ActiveCell.PasteSpecial
'格式修饰
'''''''''''''''''''''''''''''''''''''''
Range（"C6:
D1000"）.Select
Selection.NumberFormat="yyyy/mm/dd;@"
WithSelection
.HorizontalAlignment=xlLeft
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
EndWith
Range（"E6:
F1000"）.Select
Selection.NumberFormat="0%"
WithSelection
.HorizontalAlignment=xlLeft
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
EndWith
Range（"H6"）.Select
''''''''''''''''''''''''''''''''''''''''
Application.CutCopyMode=False
Sheet1.S
升级会员 