Excel VBA多工作簿多工作表汇总实例集锦.docx
- 文档编号:23933592
- 上传时间:2023-05-22
- 格式:DOCX
- 页数:125
- 大小:45.13KB
Excel VBA多工作簿多工作表汇总实例集锦.docx
《Excel VBA多工作簿多工作表汇总实例集锦.docx》由会员分享,可在线阅读,更多相关《Excel VBA多工作簿多工作表汇总实例集锦.docx(125页珍藏版)》请在冰豆网上搜索。
ExcelVBA多工作簿多工作表汇总实例集锦
1,多工作表汇总(Consolidate)
‘&ID=110630&page=1
‘两种写法都要求地址用R1C1形式,各个表格的数据布置有规定。
SubConsolidateWorkbook()
DimRangeArray()AsString
DimbkAsWorksheet
DimshtAsWorksheet
DimWbCountAsInteger
Setbk=Sheets("汇总")
WbCount=
ReDimRangeArray(1ToWbCount-1)
ForEachshtInSheets
If<>"汇总"Then
i=i+1
RangeArray(i)="'"&&"'!
"&_
("A1").(ReferenceStyle:
=xlR1C1)
EndIf
Next
("A1").ConsolidateRangeArray,xlSum,True,True
[a1].Value="姓名"
EndSub
Subsumdemo()
DimarrAsVariant
arr=Array("一月!
R1C1:
R8C5","二月!
R1C1:
R5C4","三月!
R1C1:
R9C6")
WithWorksheets("汇总").Range("A1")
.Consolidatearr,xlSum,True,True
.Value="姓名"
EndWith
EndSub
2,多工作簿汇总(Consolidate)
‘多工作簿汇总
SubConsolidateWorkbook()
DimRangeArray()AsString
DimbkAsWorkbook
DimshtAsWorksheet
DimWbCountAsInteger
WbCount=
ReDimRangeArray(1ToWbCount-1)
ForEachbkInWorkbooks'在所有工作簿中循环
IfNotbkIsThisWorkbookThen'非代码所在工作簿
Setsht=
(1)'引用工作簿的第一个工作表
i=i+1
RangeArray(i)="'["&&"]"&&"'!
"&_
("A1").(ReferenceStyle:
=xlR1C1)
EndIf
Next
Worksheets
(1).Range("A1").Consolidate_
RangeArray,xlSum,True,True
EndSub
3,多工作簿汇总(FileSearch)
‘2007-1-1‘help\汇总表.xls
Subpldrwb0531()
'汇总表.xls
'导入指定文件的数据
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
DimiAsLong,nAsLong
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm$,nm1$,m,arr,r1,col1%
=False
SetSht1=ActiveSheet
SetmyFs=
myPath=
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="*.xls"
If.Execute(SortBy:
=msoSortByFileName)>0Then
n=.
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<>"汇总表"Then
myfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
m=[a65536].End(xlUp).Row
arr=Range(Cells(3,3),Cells(m,3))
col1=col1+1
Cells(2,col1)=nm'自动获取文件名
Cells(3,col1).Resize(UBound(arr),1)=arr
savechanges:
=False
Setwb=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
=True
EndSub
‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总,运用了文本框多选功能
Publicar,ar1,nm$
Subpldrwb0531()
'汇总表.xls
'导入指定文件的数据(默认工作表1的数据)
'直接从C列依次导入
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
DimiAsLong,nAsLong
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm1$,m,arr,r1,col1%
=False
OnErrorResumeNext
SetSht1=ActiveSheet
SetmyFs=
myPath=
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="*.xls"
If.Execute(SortBy:
=msoSortByFileName)>0Then
n=.
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<>"汇总表"Then
myfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
s=s&&","
Next
s=Left(s,Len(s)-1)
ar=Split(s,",")
Forj=0ToUBound(ar1)
If=9ThenGoTo100
Setsh=(ar1(j))
m=sh.[a65536].End(xlUp).Row
arr=Range(Cells(3,3),Cells(m,3))
col1=col1+1
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:
savechanges:
=False
Setwb=Nothing
s=""
IfVarType(ar1)=8200ThenErasear1
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
=True
EndSub
PrivateSubCommandButton1_Click()
Fori=0To-1
If(i)=TrueThen
s=s&(i)&","
EndIf
Nexti
Ifs<>""Then
s=Left(s,Len(s)-1)
ar1=Split(s,",")
MsgBox"你选择了"&s
UnloadUserForm1
Else
mg=MsgBox("你没有选择任何工作表!
需要重新选择吗?
",vbYesNo,"提示")
Ifmg=6Then
Else
UnloadUserForm1
EndIf
EndIf
EndSub
PrivateSubCommandButton2_Click()
UnloadUserForm1
EndSub
PrivateSubUserForm_Initialize()
With
.List=ar‘文本框赋值
.ListStyle=1‘文本前加选择小方框
.MultiSelect=1‘设置可多选
EndWith
=&nm
EndSub
4,多工作表汇总(字典、数组)
‘&pid=2928374&page=1&extra=page%3D1
‘Data多表汇总
Subdbhz()
'多表汇总
DimSht1AsWorksheet,Sht2AsWorksheet,ShtAsWorksheet
Dimd,k,t,Myr&,Arr,x
=False
=False
Setd=CreateObject("")
ForEachShtInSheets‘删除同名的表格,获得要增加的汇总表格不重复名字
IfInStr,"-")>0Then:
GoTo100
nm=Mid(Sht.[a3],7)
d(nm)=""
100:
NextSht
=True
k=
Fori=0ToUBound(k)
after:
=Sheets
SetSht1=ActiveSheet
=Replace(k(i),"/","-")‘增加汇总表,把名字中的”/”(不能用作表名的)改为”-“
Nexti
Erasek
Setd=Nothing
ForEachShtInSheets
WithSht
.Activate
IfInStr(.Name,"-")=0Then
nm=Replace(Mid(.[a3],7),"/","-")
Myr=.[h65536].End(xlUp).Row
Arr=.Range("d10:
h"&Myr)
Setd=CreateObject("")
Fori=1ToUBound(Arr)
x=Arr(i,1)
IfNot(x)Then
x,Arr(i,5)
Else
d(x)=d(x)+Arr(i,5)
EndIf
Next
k=
t=
SetSht2=Sheets(nm)
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)=(k)
Cells(10,2).Resize(UBound(t)+1,1)=(t)
Else
Cells(myr2,1).Resize(UBound(k)+1,1)=(k)
Cells(myr2,2).Resize(UBound(t)+1,1)=(t)
EndIf
Erasek
Eraset
Setd=Nothing
EndIf
EndWith
NextSht
=True
EndSub
5,多工作簿提取指定数据(FileSearch)
‘2011-8-31
‘9188-1-1GetData()
DimBrrbz(1To200,1To19),Brrgr(1To500,1To23)
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,wbnm$
Dimi&,n&,mm&,aa$,nm1$,j&
DimSht1AsWorksheet,shAsWorksheet,wb1AsWorkbook
=False
Setwb1=ThisWorkbook
wbnm=Left,Len-4)
SetSht1=ActiveSheet
Sht1.[a2:
w200]=""
aa=Left,2)
SetmyFs=
myPath=&"\"
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="*.xls"
.SearchSubFolders=True
If.Execute(SortBy:
=msoSortByFileName)>0Then
n=.
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
Ifnm1=wbnmThenGoTo200
myfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
IfInStr,aa)Then
Ifaa="班子"Then
mm=mm+1
Brrbz(mm,1)=[b2].Value
Forj=2To18Step2
Ifj<10Then
Brrbz(mm,j)=Cells(j/2+34,11).Value
Else
Brrbz(mm,j)=Cells(j/2+34,9).Value
EndIf
Next
GoTo100
Else
If[b2]=""ThenGoTo50
mm=mm+1
Brrgr(mm,1)=[b2].Value
Brrgr(mm,2)=[e38].Value
Brrgr(mm,3)=[i38].Value
Forj=4To18Step2
Ifj<12Then
Brrgr(mm,j)=Cells(j/2+38,8).Value
Else
Brrgr(mm,j)=Cells(j/2+38,7).Value
EndIf
Next
Forj=20To23
Brrgr(mm,j)=Cells(j+28,8).Value
Next
EndIf
EndIf
50:
Next
100:
savechanges:
=False
Setwb=Nothing
200:
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
Ifaa="班子"Then
[a2].Resize(mm,19)=Brrbz
Else
[a2].Resize(mm,23)=Brrgr
EndIf
[a1].Select
SetmyFs=Nothing
EndSub
‘2011-7-15
‘&pid=5036524&page=1&extra=
Subpldrsj()
'批量导入指定文件的数据
DimmyFsAsFileSearch,myfile,Brr
DimmyPath$,Filename$,nm2$
Dimi&,j&,n&,aa$,nm$
DimSht1AsWorksheet,shAsWorksheet
=False
SetSht1=ActiveSheet
nm2=
SetmyFs=
myPath=
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="*.xls"
.SearchSubFolders=True
If.Execute(SortBy:
=msoSortByFileName)>0Then
n=.
ReDimBrr(1Ton,1To2)
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
aa=InStrRev(Filename,"\")
nm=Right(Filename,Len(Filename)-aa) '带后缀的Excel文件名
Ifnm<>nm2Then
j=j+1
myfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=("Sheet1")
Brr(j,1)=nm
Brr(j,2)=sh.[c3].Value
savechanges:
=False
Setwb=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a3].Resize(UBound(Brr),2)=Brr
SetmyFs=Nothing
=True
EndSub
Subpldrsj0707()
'6387-1-1'Report
'批量导入指定文件的数据
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,ma&,mc&
DimiAsLong,nAsLong,nn&,aa$,nm$,nm1$
DimSht1AsWorksheet,shAsWorksheet
=False
SetSht1=ActiveSheet:
nn=5
Sht1.[b5:
e27]=""
SetmyFs=
myPath=&"\data"‘指定的子文件夹内搜索
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="*.xls"
.SearchSubFolders=True
If.Execute(SortBy:
=msoSortByFileName)>0Then
n=.
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
nm1=split(mid(filename,instrrev(filename,"\")+1),".")(0)一句代码代替以下3句
‘aa=InStrRev(Filename,"\")
‘nm=Right(Filename,Len(Filename)-aa)'带后缀的Excel文件名
‘nm1=Left(nm,Len(nm)-4)'去除后缀的Excel文件名
Ifnm1<>Then
myfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
ma=[b65536].End(xlUp).Row
Ifma>6Then‘第6行是表头
Ifma>10Thenma=10‘只要取4行数据
Forii=7Toma
(nn,2).Resize(
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel VBA多工作簿多工作表汇总实例集锦 VBA 工作 汇总 实例 集锦