Excel VBA多工作簿多工作表汇总实例集锦 2Word格式.docx
《Excel VBA多工作簿多工作表汇总实例集锦 2Word格式.docx》由会员分享，可在线阅读，更多相关《Excel VBA多工作簿多工作表汇总实例集锦 2Word格式.docx（121页珍藏版）》请在冰点文库上搜索。
Subsumdemo（）
DimarrAsVariant
arr=Array（"
一月!
R1C1:
R8C5"
"
二月!
R5C4"
三月!
R9C6"
WithWorksheets（"
）.Range（"
.Consolidatearr,xlSum,True,True
.Value="
EndWith
2，多工作簿汇总（Consolidate）
‘多工作簿汇总
DimbkAsWorkbook
WbCount=Workbooks.Count
ForEachbkInWorkbooks'
在所有工作簿中循环
IfNotbkIsThisWorkbookThen'
非代码所在工作簿
Setsht=bk.Worksheets
（1）'
引用工作簿的第一个工作表
["
bk.Name&
]"
Worksheets
（1）.Range（"
）.Consolidate_
RangeArray,xlSum,True,True
3，多工作簿汇总（FileSearch）
‘2007-1-1.html###
‘help\汇总表.xls
Subpldrwb0531（）
汇总表.xls
导入指定文件的数据
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
DimiAsLong,nAsLong
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm$,nm1$,m,arr,r1,col1%
Application.ScreenUpdating=False
SetSht1=ActiveSheet
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="
*.xls"
If.Execute（SortBy:
=msoSortByFileName）>
0Then
n=.FoundFiles.Count
col1=2
ReDimmyfile（1Ton）AsString
Fori=1Ton
myfile（i）=.FoundFiles（i）
Filename=myfile（i）
aa=InStrRev（Filename,"
\"
nm=Right（Filename,Len（Filename）-aa）
nm1=Left（nm,Len（nm）-4）
Ifnm1<
汇总表"
Workbooks.Openmyfile（i）
DimwbAsWorkbook
Setwb=ActiveWorkbook
m=[a65536].End（xlUp）.Row
arr=Range（Cells（3,3）,Cells（m,3））
Sht1.Activate
col1=col1+1
Cells（2,col1）=nm'
自动获取文件名
Cells（3,col1）.Resize（UBound（arr）,1）=arr
wb.Closesavechanges:
=False
Setwb=Nothing
Else
MsgBox"
该文件夹里没有任何文件"
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能
Publicar,ar1,nm$
导入指定文件的数据（默认工作表1的数据）
直接从C列依次导入
Dimaa,nm1$,m,arr,r1,col1%
OnErrorResumeNext
ForEachshInSheets
s=s&
sh.Name&
s=Left（s,Len（s）-1）
ar=Split（s,"
UserForm1.Show
Forj=0ToUBound（ar1）
IfErr.Number=9ThenGoTo100
Setsh=wb.Sheets（ar1（j））
sh.Activate
m=sh.[a65536].End（xlUp）.Row
Cells（2,col1）=sh.[a1]
Cells（3,col1）.FormulaR1C1="
=["
nm&
ar1（j）&
RC3"
‘显示引用的工作簿工作表及单元格地址
Cells（3,col1）.AutoFillRange（Cells（3,col1）,Cells（UBound（arr）+2,col1））
‘Cells（3,col1）.Resize（UBound（arr）,1）=arr
Nextj
100:
s="
IfVarType（ar1）=8200ThenErasear1
PrivateSubCommandButton1_Click（）
Fori=0ToListBox1.ListCount-1
IfListBox1.Selected（i）=TrueThen
ListBox1.List（i）&
Nexti
Ifs<
ar1=Split（s,"
你选择了"
s
UnloadUserForm1
mg=MsgBox（"
你没有选择任何工作表！
需要重新选择吗？
vbYesNo,"
提示"
Ifmg=6Then
PrivateSubCommandButton2_Click（）
PrivateSubUserForm_Initialize（）
WithMe.ListBox1
.List=ar‘文本框赋值
.ListStyle=1‘文本前加选择小方框
.MultiSelect=1‘设置可多选
=&
nm
4，多工作表汇总（字典、数组）
‘Data多表汇总0623.xls
Subdbhz（）
多表汇总
DimSht1AsWorksheet,Sht2AsWorksheet,ShtAsWorksheet
Dimd,k,t,Myr&
Arr,x
Application.DisplayAlerts=False
Setd=CreateObject（"
Scripting.Dictionary"
ForEachShtInSheets‘删除同名的表格，获得要增加的汇总表格不重复名字
IfInStr（Sht.Name,"
-"
）>
0ThenSht.Delete:
GoTo100
nm=Mid（Sht.[a3],7）
d（nm）="
NextSht
Application.DisplayAlerts=True
k=d.keys
Fori=0ToUBound（k）
Sheets.Addafter:
=Sheets（Sheets.Count）
Sht1.Name=Replace（k（i）,"
/"
）‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“
Erasek
Setd=Nothing
ForEachShtInSheets
WithSht
.Activate
IfInStr（.Name,"
）=0Then
nm=Replace（Mid（.[a3],7）,"
Myr=.[h65536].End（xlUp）.Row
Arr=.Range（"
d10:
h"
Myr）
Fori=1ToUBound（Arr）
x=Arr（i,1）
IfNotd.exists（x）Then
d.Addx,Arr（i,5）
d（x）=d（x）+Arr（i,5）
t=d.items
SetSht2=Sheets（nm）
Sht2.Activate
myr2=[a65536].End（xlUp）.Row+1
Ifmyr2<
9Then
Cells（9,1）.Resize（1,2）=Array（"
PartNo."
TTLQty"
Cells（10,1）.Resize（UBound（k）+1,1）=Application.Transpose（k）
Cells（10,2）.Resize（UBound（t）+1,1）=Application.Transpose（t）
Cells（myr2,1）.Resize（UBound（k）+1,1）=Application.Transpose（k）
Cells（myr2,2）.Resize（UBound（t）+1,1）=Application.Transpose（t）
Eraset
5，多工作簿提取指定数据（FileSearch）
‘2011-8-31
‘9188-1-1.html
SubGetData（）
DimBrrbz（1To200,1To19）,Brrgr（1To500,1To23）
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,wbnm$
Dimi&
n&
mm&
aa$,nm1$,j&
DimSht1AsWorksheet,shAsWorksheet,wb1AsWorkbook
Setwb1=ThisWorkbook
wbnm=Left（wb1.Name,Len（wb1.Name）-4）
Sht1.[a2:
w200]="
aa=Left（Sht1.Name,2）
myPath=ThisWorkbook.Path&
.SearchSubFolders=True
nm1=Split（Mid（Filename,InStrRev（Filename,"
）+1）,"
."
）（0）
Ifnm1=wbnmThenGoTo200
IfInStr（sh.Name,aa）Then
Ifaa="
班子"
mm=mm+1
Brrbz（mm,1）=[b2].Value
Forj=2To18Step2
Ifj<
10Then
Brrbz（mm,j）=Cells（j/2+34,11）.Value
Brrbz（mm,j）=Cells（j/2+34,9）.Value
If[b2]="
ThenGoTo50
Brrgr（mm,1）=[b2].Value
Brrgr（mm,2）=[e38].Value
Brrgr（mm,3）=[i38].Value
Forj=4To18Step2
12Then
Brrgr（mm,j）=Cells（j/2+38,8）.Value
Brrgr（mm,j）=Cells（j/2+38,7）.Value
Forj=20To23
Brrgr（mm,j）=Cells（j+28,8）.Value
50:
200:
[a2].Resize（mm,19）=Brrbz
[a2].Resize（mm,23）=Brrgr
‘2011-7-15
Subpldrsj（）'
批量导入指定文件的数据?
?
DimmyFsAsFileSearch,myfile,Brr?
DimmyPath$,Filename$,nm2$?
j&
aa$,nm$?
DimSht1AsWorksheet,shAsWorksheet?
Application.ScreenUpdating=False?
SetSht1=ActiveSheet?
nm2=ActiveWorkbook.Name?
SetmyFs=Application.FileSearch?
myPath=ThisWorkbook.Path?
WithmyFs?
.NewSearch?
.LookIn=myPath?
.FileType=msoFileTypeNoteItem?
.SearchSubFolders=True?
0Then?
n=.FoundFiles.Count?
ReDimBrr（1Ton,1To2）?
ReDimmyfile（1Ton）AsString?
Fori=1Ton?
myfile（i）=.FoundFiles（i）?
Filename=myfile（i）?
）?
nm=Right（Filename,Len（Filename）-aa）?
带后缀的Excel文件名?
Ifnm<
nm2Then?
j=j+1?
Workbooks.Openmyfile（i）?
DimwbAsWorkbook?
Setwb=ActiveWorkbook?
Setsh=wb.Sheets（"
Sheet1"
Brr（j,1）=nm?
Brr（j,2）=sh.[c3].Value?
=False?
Setwb=Nothing?
EndIf?
Next?
Else?
EndWith?
Sht1.Select?
[a3].Resize（UBound（Brr）,2）=Brr?
SetmyFs=NothingApplication.ScreenUpdating=TrueEndSub
Subpldrsj0707（）
6387-1-1.html
Report2.xls
批量导入指定文件的数据
DimmyPathAsString,Filename$,ma&
mc&
DimiAsLong,nAsLong,nn&
aa$,nm$,nm1$
SetSht1=ActiveSheet:
nn=5
Sht1.[b5:
e27]="
\data"
‘指定的子文件夹内搜索
nm1=split（mid（filename,instrrev（filename,"
）（0）一句代码代替以下3句
‘aa=InStrRev（Filename,"
‘nm=Right（Filename,Len（Filename）-aa）'
带后缀的Excel文件名
‘nm1=Left（nm,Len（nm）-4）'
去除后缀的Excel文件名
Sht1.NameThen
ma=[b65536].End（xlUp）.Row
Ifma>
6Then‘第6行是表头
10Thenma=10‘只要取4行数据
Forii=7Toma
Sht1.Cells（nn,2）.Resize（1,3）=Cells（ii,2）.Resize（1,3）.Value
Sht1.Cells（nn,5）=Cells（ii,6）.Value
nn=nn+1
Nextii
mc=[d65536].End（xlUp）.Row
Ifmc>
7Then‘第7行是表头
11Thenmc=11‘只要取4行数据
Forii=8Tomc
Sht1.Cells（nn,2）.Resize（1,3）=Cells（ii,4）.Resize（1,3）.Value
Sht1.Cells（nn,5）=Cells（ii,8）.Value
Nextsh
升级会员 