Excel VBA多工作簿多工作表汇总实例集锦.docx

《Excel VBA多工作簿多工作表汇总实例集锦.docx》由会员分享，可在线阅读，更多相关《Excel VBA多工作簿多工作表汇总实例集锦.docx（127页珍藏版）》请在课桌文档上搜索。

1、1,多工作表汇总(ConSOlidate)两种写法都要求地址用RlCI形式，各个表格的数据布置有规定。SubConsolidatcWorkbookODimRangeArrayOAsStringDimbksWorksheetDimshtAsWorksheetDimWbCountAsIntegerSetbk=SheetS(汇总WbCount=Sheets1CountReDimRangeArrayI1ToWbCount-1)ForEachshtInSheetsIfsht.Name汇总Theni=i+1RangeArrayfi)=&sht.Name&_sht.Range(Al)CurrentRegio

2、n.Address(ReferenceStyle:=xlRlCl)EndIfNextbk.Range(A1).ConsolidateRangeArray,xlSum,True,Trueal.Value=姓名ForEachbkInWorkbooks在全部工作簿中循环IfNotbkIsThisWorkbookThen非代码所在工作簿Setsht=bk.Workshcets引用工作簿的第一个工作表i=i+1RangeArray(i)=&bk.Name&sht.Name&,!&_sht.Range(A).CurrentRegion.Address(ReferenceStyle=xlRlCl)EndIf

3、NextWorksheets(I).Range(A1n).Consolidate_RangeArray,xlSum,True,TrueEndSub3,多工作傅汇总O*2007-1-1.html#help汇总表.xlsSubpld11vbO5310汇总表xls导入指定文件的数据DimmyFsAs.=*.xlsIf.Execute(SortByi=TnsoSortBy)0Thenn=.Foundcoll=2RcDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,)nm=Right(,1.en(

4、)-aa)nml=1.eft(nm,1.en(nm)-4)Ifnmlv”汇总表ThenWorkbooks.Openmyfilc(i)DimwbAsWorkbookSetwb=ActiveWorkbookForEachshInSheetsS=s&sh.Name&JNextS=1.eft(s,1.en(三)-1)ar=Split(s,UserForm1.ShowForj=OToUBound(arl)IfErr.Number=9ThenGoTo100Setsh=wb.Sheets(arl(j)sh.Activatem=sh.a65536.End(xlUp).Rowarr=Range(CelIS(3,

5、3),Cells(m,3)Sht1.Activatecoil=coll+1Cells(2,coll)=sh.alCells(3,colIJ.FormulaRlCl=&nm&T&arl(j)&!RC3显示引用的工作簿工作表与单元格地址Cells(3,coll).AutoFillRange(Cells(3,coll),Cells(UBound(arr)+2,coll)iCells(3,coll).Resize(UBoundfarr),1)=arrNextj100:wb.CloseSaVeChanges:=FalSeSetwb=NothingS=IfVarType(arl)=8200ThenEras

6、earlEndIfElseMsgBox该文件夹里没有任何文件”EndIfEndWitha1.SelectSetmyFs=NothingApplication-ScreenUpdating=TrueEndSubPrivateSubCommandButtonl_Click()Fori=OTo1.istBoxl.1.istCount-1If1.istBox1.Selectedfi)=TrueThens=s&1.istBoxl.1.ist(i)&,EndIfNextiIfsThens=1.eft(s,1.en(三)-1)arl=Split(s,MsgBox你选择了&sUnloadUserFormlEl

7、semg=MsgBoXr你没有选择任何工作表！须要重新选择吗？,VbYesNo,”提示)Ifmg=6ThenElseUnloadUserFormlEndIfEndIfEndSubPrivateSubCommandBUtton2_CliCk()UnloadUserForm1EndSubPrivateSubUserFormJnitializeOWithMe.1.istBoxl.1.ist=ar文本框赋值.1.istStyle=1文本前加选择小方框.MultiSelect=1设置可多选EndWithMe.1.abell.Caption=Me.1.abell.Caption&nmEndSub4,多工作

8、表汇总（字典、Mffi）*Data多表汇总0623.xlsSubdbhz()多表汇总DimShtlAsWorksheet,Sht2AsWorksheet,ShtAsWorksheetDimdfk,t,Myr&,Arr,xApplication-ScreenUpdating=FalseApplication.DisplayzMerts=FalseSetd=CreateobjectCScripting.Dictionary)ForEachShtInSheets删除同名的表格，获得要增加的汇总表格不重且名字IfInStr(Sht.Name,OThenSht.Delete:GoTo100nm=Mid(

9、Sht.a3,7)d(nm)=100:NextShtApplication-DisplayAlerts=Truek=d.keysFori=0ToUBound(k)Sheets.Addafter:=Sheets(Sheets.Count)SetShtl=ActiveSheetShtkName=Replace(k(i),增加汇总表，把名字中的“(不能用作表名的)改为-“NextiErasekSetd=NothingForEachShtInSheetsWithSht.ActivateIfInStr(.Name,0Thennm=RCPlaCe(MidUa3,7),Myr=.h65536.End(xlU

10、p).RowArr=.RangefdlOrh&Myr)Setd=CreateObject(Scripting.Dictionary)Fori=1ToUBound(Arr)x=Arr(i,1)IfNotd.exists(x)Thend.Addx,Arr(i,5)Elsed(x)=d(x)+Arr(i,5)EndIfk=d.keyst=d.itemsSetSht2=Sheets(nm)Sht2.Activatemyr2=a65536.End(xlUp).Row+1Ifmyr2OThenn=.FoundReDimmyfile(lTon)AsStringFori=1Tonmyfile(i)=.Foun

11、dFiles(i)=myfile(i)nml=Split(Mid(,InStrRev(,)+D,)(0)Ifnml=wbnmThenGoTo200Workbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookForEachshInSheetsIfInStr(sh.Name,aa)Thensh.Activatemm=mm+1Brrbz(mm,1)=b2.ValueForj=2To18Step2Ifj10ThenBrrbz(mm,j)=CellsQ/2+34,1l).ValueElseBrrbz(mm,j)=Cells(j/2+34,9).Va

12、lueEndIfNextGoTo100ElseIfIb2=ThenGoTo50mm=mm+1Brrgr(mm,1)三b2.ValueBrrgr(mm,2)=e38).ValueBrrgr(mm,3)=i38.ValueForj=4To18Step2Ifj12ThenBrrgr(mm,j)=Cells(j/2+38,8).ValueElseBrrgr(mm,j)=Cells(j/2+38,7).ValueEndIfNextForj=20To23Brrgr(mm,j)=Cells(j+28,8).ValueNextEndIfEndIf50:Next100:wb.CloseSavechangesi=

13、FalseSetwb=Nothing200:NextElseMsgBox”该文件夹里没有任何文件”EndIfEndWitha2.Resize(mm,19)=BrrbzElsea2.Rcsize(mm,23)=BrrgrEndIfa1.SelectSetmyFs=NothingEndSub*2011-7-15OThenn=.FoundReDimBrr(lTon,1To2)ReDimmyfile(lTon)AsStringFori=1Tonmyfile(i)=.FoundFilesfi)=myfile(i)aa=InStrRev(,)nm=Right(,1.en()-aa)带后缀的Excel文件名

14、Ifnmnm2Thenj=j+1Workbooks.Openmyfile(i)DimwbAsWorkbookSetWb=ActiveWorkbookSetsh=wb.Shcets(Sheet1n)Brr(j,1)=nmApplication.ScreenUpdating=FalseSetShtl=ActiveSheet:nn=5Shtl.(b5:e27|=SetmyFs=Application.myPath=ThisWorkbook-Path&data指定的子文件夹内搜寻WithmyFs.NewSearch.1.ookIn=myPath.=mso.=*.xls.SearchSubFolders

15、=TrueIf.ExecutefSortBy:=msoSortBy)OThenn=.FoundRcDimmyfile(1Ton)AsStringFori=1Tonmyfilc(i)=.FoundFilcs(i)=myfile(i)nml=split(mid(,)+l),.)(O)一句代码代替以下3句aaHInStrReV(,、)带后缀的Excel文4nm=Right(,1.enO-aa)件名EndIfme=d65536.End(xlUp).RowIfme7Then第7行是表头Ifme11Thenme=11只要取4行数据Forii=8TomeShtl.Cclls(nn,2).Resized,3)

16、=Cells(ii,4).Resize(l,3).ValueShtl.Cells(nn,5)=Cells(ii,8).Valuenn=nn+1NextiiGoTo100ElseGoTo100EndIf100:Nextshwb.CloseSaVeChanges:=FaISeSetwb=NothingEndIfNextElseMsgBox”该文件夹里没有任何文件”EndIfEndWitha1.SelectSetmyFs=NothingApplication-ScreenUpdating=TrueEndSubsum.xlsSubpldrsj0724()批地导入指定文件的数据DimmyFsAs,myf

17、ile,Myrl&,ArrDimmyPath$,$,nm2$Dimi&,j&,n&,nn&,aa$,nm$,nml$DimShtlAsWorksheet,shAsWorksheetApplication-ScreenUpdating=FalseSetShtl=ActiveSheetMyrl=Sht1.a65536.End(xlUp).RowArr=Shtl.Rangc(a3:b&Myrl)Sht!.RangeCbSib*&Myr1).ClearContentsnm21.eft(ctiveWorkbook.Name,1.en(ActiveWorkbook-Name)-4)SetmyFs=Appl

18、ication.myPath三ThisWorkbook-PathWithmyFs.NewSearch.1.ookIn=myPath.=mso.=*.xlsIf.Execute(SortByi=InsoSortBy)OThenn=.FoundReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,)nm=Right(,()-aa)带后缀的Excel文件名nml=1.eft(nm,1.en(nm)-4)去除后缀的Excel文件名Ifnmlnm2ThenEndWithSht1.Selectb3)

19、.Rcsizc(UBoundArr),1)=Application.Index(Arr,0,2)SetmyFs=NothingApplication1ScreenUpdating=TrueEndSub6,多工作超UI指定数据（数Ia）Subfpkf()Application-ScreenUpdating=FalseDimMyr&,Arr,yf,x&,MyrI&,rlDimShtAsWorksheetMyr=Sheetl.b65536.End(xlUp).RowSheetl.Range(c8:h&Myr).ClearContentsArr=Sheet1.RangeC,c8rh&Myr)j8.Fo

20、rmula三-rc-9rd8j8.AutoFillRange(j8:j&Myr)Range(j8:j&Myr)=Range(j8:j&Myr).ValueForEachShtInSheetsIfSht.NameSheet1.NameThenyf=1.eft(Sht.Name,1.en(Sht.Name)-2)Sht.ActivateMyrl=a65536.End(xlUp).Row-1Forx=7ToMyrlIfCells(x,1),ThenSetrl=Sheetl.Range(Hj:j).Find(Cells(x,1)&T&Cells(x,2)IfNotrlIsNothingThenArr(

21、rl.Row-7,yf)-Cells(x,ar)EndIfEndIfNextxEndIfNextSheet1.Activatec8.ResizefUBound(Arr),UBound(Arr,2)=Arrj:j.ClearApplication-ScreenUpdating=TrueEndSub7,多工作停多工作表查询汇总去重复值（字典数蛆）具体记录.xls3个工作簿须要都打开SubxxjlDimShtlAsWorksheet,ShtAsWorksheetDimwb1AsWorkbook,wb2AsWorkbook,wb3AsWorkbookDimi&,Myr2&,Arr2,Myr&,Arr,

22、Myr18&,xm$,yl$Application.ScreenUpdating=FalseSetwb1=ActiveWorkbookSetwb2=WOrkbOOkSr购进”)Setwb3=WorkbooksCfie11)wb2.ActivateMyr2=a65536).End(xlUp).RowArr2=Range(a2:d&Myr2)wb3.ActivateFori=1ToUBound(Arr2)wb3.Activatexm=Arr2(i,2)ForEachShtInSheetsIfSht.Name=XmThenSht-ActivateMyr=a65536.End(xlUp).RowArr

23、=Rangefakb&Myr)Forj三1ToUBound(Arr)yl=ArrQ,Dwb1.ActivateForEachShtlInSheetsIfShtl,Name=ylThenSht1.ActivateMyrl=a65536.End(xlUp).Row+1Cclls(Myrl,1)=Arr2(i,1)Cells(Myrl,3)=Arr2(i,3)Cells(Myrl,2)=Arr2(i,4)*Arr(j,2)ExitForEndIfNextNextjGoTo100EndIfNext100:NextiCallqccfApplication-ScreenUpdating=TrueEndSu

24、bSubqccf()DimShtAsWorksheet,Myr&,Arr,i&,XDimd,k,t,Arrl,j&Application1ScreenUpdating=FalseForEachShtInSheetsSht-ActivateMyr=a65536.End(xlUp).RowArr=Rangera2:c&Myr)Setd=CreateObject(Scripting.Dictionary)IfMyrOThennm=1.cft(Shtl.al,(Shtl.al)-5)Shtl.ActivateWithmyFs.NewSearch.1.ookIn=myPath.=mso.=nm&.xls

25、.SearchSubFolders三TrueIf.Exccute(SortByr=InsoSortBy)OThenmyfile=.FoundFiles(I)Workbooks.OpenmyfileDimwbAsWorkbookSetwb=ActivcWorkbookSetsh三Wb.ActiveSheetm=sh.(a65536.End(xlUp).Rowarr=sh.Range(Cells(2,1),Cells(m,6)yf=Val(Split(arr(2,1),.)(1)Sht1.ActivateForj=1ToUBound(arr)Setrl=Sht1.Range(cx)Fi11d(ar

26、r(j,3)IfrlIsNothingThenml=Sht1.d65536.End(xlUp).RowCells(ml,1).EntireRowJnsertshiftz=xlUpCells(ml,1)=Cells(ml-1,1)+1Cells(ml,2)=arr(j,3)Cells(ml,yf+3)=arr(j,6)EndIfNextjwb.Closesavechanges:=FalseSetwb三NothingEndUEndWithEndIfNextSetmyFs=NothingApplication-DisplayAlerts三TrueApplication1ScreenUpdating=

27、TrueEndSub9,多工作停汇总（字典）Subpldrwb11230合并ls导入指定文件的数据DimmyFsAsDimmyPathAsString,$Dimi&,n&,y&,bb,j&,xDimShtlAsWorksheet,shAsWorksheetDimaa,nm$,nml$,m,Arr,rl,mm&Dimd,k,t,dlftlApplication.ScreenUpdating=Falsemm=8SetShtl=ActiveSheetShtl.a8:hl000.ClearContentsSetmyFs=Application.myPath=ThisWorkbook1PathWithm

28、yFs.NewSearch.1.ookIn=myPath.=mso.=*.xls.SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)OThenn=.FoundRcDimmyfile(1Ton)AsStringFori=1Tonmyfilc(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,)nm=Right(,1.en()-aa)nml=1.eft(nm,1.en(nm)-4)Ifnmlv合并ThenWorkbooks.Openmyfilc(i)DimwbAsWorkbookSetwb=ActiveWorkbook

29、m三a65536.End(xlUp).RowArr=Range(Cells(8,1),Cells(m,7)Setd=CreateObjectCScripting.Dictionarjf)Setdl=CreateobjeCtrSCriPting.Dictionary)Forj=1ToUBound(Arr)x=Year(Arr(j,1)&年&Month(Arr(j,1)&月&T&Arr(j,2)&Arr(j,Arr(j,5)d(x)=d(x)+Arr(j,4)dl(x)=Arr(j,7)Nextk=d.keyst=d.itemstl=dl.itemsSht1.ActivateFory=OToUBo

30、und(k)bb=Split(k(y),)Cells(mm,1)=nmlCells(mm,2)=bb(O)Cells(mm,3)=bb(l)Cclls(mm,4)=bb(2)Cells(mm,5)-t(y)Cells(mm,6)=bb(3)Cells(mm,7)=t(y)*bb(3)Cells(mm,8)=tl(y)mm=mm+1Nextwb.Closesavechanges:=FalseSetwb=NothingSetd=NothingSetdl=NothingEndIfNextElseMsgBox”该文件夹里没有任何文件”EndIfEndWitha1.SelectSetmyFs=Nothi

31、ngApplication1ScreenUpdating=TrueEndSub10,多工作博多工作表提取数据(DoWhiIe)年度汇总lsSubndhz()DimArr,myPath$,myNameS,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&Application.ScreenUpdating=FalseSetwb=ThisWorkbookfunm=年度汇总.xlsmyPath=ThisWorkbook-Path&myName=Dir(myPath&*.xls)DoWhilemyNameAndmyNamefunmWithGetObj

32、ect(myPath&myName)Arr=.Sheets(领料).Range(Al).CurrentRegionForEachshInwb.Sheetsshnm=sh.Namesh.ActivateIfInStr(Shnm,班)OThencol=11Elsecol=7EndIfFori=2ToUBound(Arr)IfArr(i,col)=shnmThenm=sh.a65536.End(xlUp).Row+1Cells(m,l).Resize(l,12)=Application.Index(Arr,i,0)EndIfNextNext.CloseFalseEndWithmyNamc=Dir1.

33、oopApplication-ScreenUpdating=TrueEndSubSubtqsj()DimArr,myPath$,myNameS,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&,Myr&,ShtlAsWorksheet,pm$Application.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetfunm=提取数据,xls”:m=1myPath=ThisWorkbookTath&myNamc=Dir(myPath&*.xls)DoWhilemyNameAndmy

34、NamefunmWithGctObject(myPath&myNamc)Setwb=Workbooks(myName)ForEachshInwb.Sheetsshnm=sh.Namesh.Activatepm=sh.a4.ValueMyr=sh.(a65536.End(xlUp).RowArr三sh.Range(b9:eM&Myr)m=m+1WithShtl.Cells(m,1)=myName.Cells(m,2)=pm.Cclls(m,3)=shnm.Cells(m,4).Resize(UBoundfArr),4)=ArrEndWithm=m+UBound(Arr)-1Next.CloseF

35、alseArr=sh.Range(a2:f&m)Cells(n,l).Resize(m-1,6)=Arrn=n+m-1.CloseFalseEndWithmyName=Dir1.oopSht.Range(a2:f&n-1).Borders.1.ineStyle=1Application.ScreenUpdating=TrueEndSub汇总工作表xls2010-2-7Subndhz()DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheetDimm&,funm$Fshnm$,col%,i&,Myr&,ShtlAsWorksheetApplication

36、.ScreenUpdating=FalseOnErrorResumeNextSetShtl=ActiveSheetfunm=汇总工作表.xls:m三1myPath=ThisWorkbook.Path&myName=Dir(myPath&*.xls)DoWhilemyNameAndmyNamefunmWithGetObject(myPath&myName)Setwb=Workbooks(myName)ForEachshInwb.Sheetsshnm=sh.Namesh.ActivateMyr=ShJa65536.End(XIUP).RowArr=sh.Range(al:c&Myr)Fori=1T

37、oUBound(Arr)IfArr(i,3)50Thenm=m+1Shtl.Cells(m,l).Resize(l,3)Application.Index(A,i,0)Shtl.Cells(m,4)=Arr(i+1,3)Shtl.Cells(m,5)=Arr(i+2,3)Shtl.Cells(m,6)=shnmEndIfNextNext.CloseFalseEndWith1.oopApplication-ScreenUpdating=TrueEndSubSubndhz()DimArr,myPath$,myNameS,wbASWorkbook,shAsWorksheetDimm&,funm$,shnmS,col%,i&,Myr&,ShtlsWorksheetApplication.ScreenUpdating=FalseOnErrorResumeNextSetShtl=ActiveSheetfunm=汇总工作表.xls:m=1myPath=ThisWorkbook.P