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

1,多工作表汇总(ConSOlidate)'两种写法都要求地址用RlCI形式，各个表格的数据布置有规定。SubConsolidatcWorkbookODimRangeArrayOAsStringDimbksWorksheetDimshtAsWorksheetDimWbCountAsIntegerSetbk=SheetS("汇总WbCount=Sheets1CountReDimRangeArrayI1ToWbCount-1)ForEachshtInSheetsIfsht.Name<>"汇总"Theni=i+1RangeArrayfi)=&sht.Name&_sht.Range("Al")CurrentRegion.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)EndIfNextWorksheets(I).Range("A1n).Consolidate_RangeArray,xlSum,True,TrueEndSub3,多工作傅汇总O*2007-1-1.html#'help汇总表.xlsSubpld11vbO5310'汇总表xls导入指定文件的数据DimmyFsAs.="*.xls"If.Execute(SortByi=TnsoSortBy)>0Thenn=.Foundcoll=2RcDimmyfile(1Ton)AsStringFori=1Tonmyfile(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=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,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)=8200ThenErasearlEndIfElseMsgBox"该文件夹里没有任何文件”EndIfEndWitha1.SelectSetmyFs=NothingApplication-ScreenUpdating=TrueEndSubPrivateSubCommandButtonl_Click()Fori=OTo1.istBoxl.1.istCount-1If1.istBox1.Selectedfi)=TrueThens=s&1.istBoxl.1.ist(i)&","EndIfNextiIfs<>""Thens=1.eft(s,1.en(三)-1)arl=Split(s,MsgBox"你选择了"&sUnloadUserFormlElsemg=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,多工作表汇总（字典、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(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(xlUp).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+1Ifmyr2<9ThenCenS1).ReSiZe(1,2)=Array("PartNo.","TT1.Qty")Cells(10,1).RCSiZe(UBoUnd(k)+1,1)=Application-Transpose(R)Cells(10,2).ReSiZe(UBOUnd(t)+1,1)=Application-Transposeft)ElseCells(myr2,1).Resize(UBoundIk)+1,1)=Application.Transpose(k)Cells(myr2,2).ResizeIUBound(t)+1,1)=Application.Transpose(t)EndIfErasekErasetSetd=NothingEndIfEndWithNextShtApplication1ScrcenUpdating=TrueEndSub5,多工作便提取指定第疆O*2011-8-31*9188-l-l.htmlSubGetDataODimBrrbz(lTo200,1To19),Brrgr(lTo500,1To23)DimmyFsAs,myfileDimmyPathASString,$,wbnm$Dimi&,n&,Tnm&,aa$,nm1$,j&DimShtlsWorksheet,shAsWorksheet,wblAsWorkbookApplication-ScreenUpdating=FalseSetWbI=ThisWorkbookwbnm=1.eft(wbl.Name,1.en(wbl.Name)-4)SetShtl=/XctiveSheetShtl.a2:w200aa=1.eft(Shtl.Name,2)SetmyFs=Application.myPath=ThisWorkbook.Path&""WithmyFs.NcwSearch.1.ookIn=myPath.=mso.="*.xls".SearchSubFolders=TrueIf.Execute(SortByi=InsoSortBy)>OThenn=.FoundReDimmyfile(lTon)AsStringFori=1Tonmyfile(i)=.FoundFiles(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=2To18Step2Ifj<10ThenBrrbz(mm,j)=CellsQ/2+34,1l).ValueElseBrrbz(mm,j)=Cells(j/2+34,9).ValueEndIfNextGoTo100ElseIfIb2=ThenGoTo50mm=mm+1Brrgr(mm,1)三b2.ValueBrrgr(mm,2)=e38).ValueBrrgr(mm,3)=i38.ValueForj=4To18Step2Ifj<12ThenBrrgr(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=FalseSetwb=Nothing200:NextElseMsgBox”该文件夹里没有任何文件”EndIfEndWitha2.Resize(mm,19)=BrrbzElsea2.Rcsize(mm,23)=BrrgrEndIfa1.SelectSetmyFs=NothingEndSub*2011-7-15<Subpldrsj()'批最导入指定文件的数据DimmyFsAs,myfile,BrrDimmyPath$,$,nm2$Dimi&,j&,n&,aa$,nm$DimShtlAsWorksheet,shAsWorksheetApplication.ScreenUpdating=FalseSetShtl=ActiveSheetSht1.Cells.ClearContentsnm2=ActiveWorkbook-NameSetmyFs=Application.WithmyFs.NewSearch.1.ookIn=myPath.=mso.="*.xlsn.SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)>OThenn=.FoundReDimBrr(lTon,1To2)ReDimmyfile(lTon)AsStringFori=1Tonmyfile(i)=.FoundFilesfi)=myfile(i)aa=InStrRev(,"")nm=Right(,1.en()-aa)'带后缀的Excel文件名Ifnm<>nm2Thenj=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=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).RowIfme>7Then'第7行是表头Ifme>11Thenme=11'只要取4行数据Forii=8TomeShtl.Cclls(nn,2).Resized,3)=Cells(ii,4).Resize(l,3).ValueShtl.Cells(nn,5)=Cells(ii,8).Valuenn=nn+1NextiiGoTo100ElseGoTo100EndIf100:Nextshwb.CloseSaVeChanges:=FaISeSetwb=NothingEndIfNextElseMsgBox”该文件夹里没有任何文件”EndIfEndWitha1.SelectSetmyFs=NothingApplication-ScreenUpdating=TrueEndSub'sum.xlsSubpldrsj0724()'批地导入指定文件的数据DimmyFsAs,myfile,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=Application.myPath三ThisWorkbook-PathWithmyFs.NewSearch.1.ookIn=myPath.=mso.="*.xls"If.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文件名Ifnml<>nm2ThenEndWithSht1.Selectb3).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.Formula三-rc-9""""rd"8"j8.AutoFillRange("j8:j"&Myr)Range("j8:j"&Myr)=Range("j8:j"&Myr).ValueForEachShtInSheetsIfSht.Name<>Sheet1.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(rl.Row-7,yf)-Cells(x,"ar")EndIfEndIfNextxEndIfNextSheet1.Activatec8.ResizefUBound(Arr),UBound(Arr,2)=Arrj:j.ClearApplication-ScreenUpdating=TrueEndSub7,多工作停多工作表查询汇总去重复值（字典数蛆）'具体记录.xls'3个工作簿须要都打开SubxxjlDimShtlAsWorksheet,ShtAsWorksheetDimwb1AsWorkbook,wb2AsWorkbook,wb3AsWorkbookDimi&,Myr2&,Arr2,Myr&,Arr,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=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=TrueEndSubSubqccf()DimShtAsWorksheet,Myr&,Arr,i&,XDimd,k,t,Arrl,j&Application1ScreenUpdating=FalseForEachShtInSheetsSht-ActivateMyr=a65536.End(xlUp).RowArr=Rangera2:c"&Myr)Setd=CreateObject("Scripting.Dictionary")IfMyr<3ThenGoTo1OOFori=1ToUBound(Arr)X=Arr(i,1)&","&Arr(i,3)IfNotd.exists(x)Thend(x)=Arr(i,2)Elsed(x)=d(x)+rr(i,2)EndIfNextk-d.keyst=d.itemsReDimArrl(1ToUBound(k)+1,1To3)Forj=0ToUBound(k)Arrl(j+1,D-Split(kG),",")(0)Arrl(j+l,3)=Split(k(j)fY)(l)Arrl(j+l,2)=t(j)NextjRange("a2x"&Myr).ClearContentsa2.Rcsize(UBound(Arr1),3)=Arrl100:Setd=NothingNextApplication-ScreenUpdating=TrueEndSub8,多工作需对比OSubdgzbdb'多工作簿对比'by:蓝桥2009-11-7DimmyFsAsDimmyPathAsString,$Dimi&,n&,nm$,myShtlAsWorksheet,shAsWorksheetDimwblAsWorkbook,yf,j&,ml&Dimm,arr,rlApplication.ScreenUpdating=FalseApplication-DisplayAlerts=FalseOnErrorResumeNextSetwb1=ThisWorkbookSetmyFs=Application.myPath=ThisWorkbook-PathForEachShtlInSheetsIfInStr(Sht1.al,'费用明细表")>OThennm=1.cft(Shtl.al,(Shtl.al)-5)Shtl.ActivateWithmyFs.NewSearch.1.ookIn=myPath.=mso.=nm&".xls".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(arr(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=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=ThisWorkbook1PathWithmyFs.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=ActiveWorkbookm三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=OToUBound(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=NothingApplication1ScreenUpdating=TrueEndSub10,多工作博多工作表提取数据(DoWhiIe)'年度汇总lsSubndhz()DimArr,myPath$,myNameS,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&Application.ScreenUpdating=FalseSetwb=ThisWorkbookfunm="年度汇总.xls"myPath=ThisWorkbook-Path&""myName=Dir(myPath&"*.xls")DoWhilemyName<>""AndmyName<>funmWithGetObject(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.oopApplication-ScreenUpdating=TrueEndSub<Subtqsj()DimArr,myPath$,myNameS,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&,Myr&,ShtlAsWorksheet,pm$Application.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetfunm="提取数据,xls”:m=1myPath=ThisWorkbookTath&""myNamc=Dir(myPath&"*.xls")DoWhilemyName<>""AndmyName<>funmWithGctObject(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.CloseFalseArr=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.ScreenUpdating=FalseOnErrorResumeNextSetShtl=ActiveSheetfunm="汇总工作表.xls":m三1myPath=ThisWorkbook.Path&""myName=Dir(myPath&"*.xls")DoWhilemyName<>""AndmyName<>funmWithGetObject(myPath&myName)Setwb=Workbooks(myName)ForEachshInwb.Sheetsshnm=sh.Namesh.ActivateMyr=ShJa65536.End(XIUP).RowArr=sh.Range("al:c"&Myr)Fori=1ToUBound(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