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

1，多工作表汇总(Consolidate)’两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。SubConsolidateWorkbook()DimRangeArray()AsStringDimbkAsWorksheetDimshtAsWorksheetDimWbCountAsIntegerSetbk=Sheets("汇总”)WbCount=Sheets.CountReDimRangeArray(1ToWbCount-1)ForEachshtInSheetsIfsht.Name<>"汇总"Theni=i+1RangeArray(i)二m"&sht.Name&"'!"&_sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)EndIfNextbk.Range("A1").ConsolidateRangeArray,xlSum,True,True[a1].Value=，姓名”EndSubSubsumdemo()DimarrAsVariantarr=Array("一月!R1C1:R8c5","二月!R1C1:R5c4","三月!R1C1:R9C6")WithWorksheetsC汇总").Range("A1").Consolidatearr,xlSum,True,True.Value=，姓名"EndWithEndSub2，多工作簿汇总(Consolidate)'多工作簿汇总SubConsolidateWorkbook()DimRangeArray()AsStringDimbkAsWorkbookDimshtAsWorksheetDimWbCountAsIntegerWbCount=Workbooks.CountReDimRangeArray(1ToWbCount-1)ForEachbkInWorkbooks在所有工作簿中循环IfNotbkIsThisWorkbookThen非代码所在工作簿Setsht=bk.Worksheets(1)引用工作簿的第一个工作表i=i+1RangeArray(i)="'["&bk.Name&"]"&sht.Name&"'!"&_sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)EndIfNextWorksheets(1).Range("A1").Consolidate_RangeArray,xlSum,True,TrueEndSub3,多工作簿汇总()‘2007-1-1.html###‘help\汇总表.xlsSubpldrwb0531()'汇总表.xls'导入指定文件的数据DimmyFsAsDimmyPathAsString,$DimiAsLong,nAsLongDimSht1AsWorksheet,shAsWorksheetDimaa,nm$,nm1$,m,arr,r1,col1%Application.ScreenUpdating=FalseSetSht1=ActiveSheetSetmyFs=Application.myPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.二mso.="*.xls"If.Execute(SortBy:=msoSortBy)>0Thenn=.Foundcol1=2ReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,"\")nm=Right(,Len()-aa)nm1=Left(nm,Len(nm)-4)Ifnm1<>"汇总表"ThenWorkbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookm=[a65536].End(xlUp).Rowarr=Range(Cells(3,3),Cells(m,3))Sht1.Activatecol1=col1+1Cells(2,col1)=nm '自动获取文件名Cells(3,col1).Resize(UBound(arr),1)=arrwb.Closesavechanges:=FalseSetwb=NothingEndIfNextElseMsgBox"该文件夹里没有任何文件"EndIfEndWith[a1].SelectSetmyFs=NothingApplication.ScreenUpdating=TrueEndSub根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Publicar,ar1,nm$Subpldrwb0531()'汇总表.xls'导入指定文件的数据(默认工作表1的数据)'直接从C列依次导入DimmyFsAsDimmyPathAsString,$DimiAsLong,nAsLongDimSht1AsWorksheet,shAsWorksheetDimaa,nm1$,m,arr,r1,col1%Application.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetSetmyFs=Application.myPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.二mso.="*.xls"If.Execute(SortBy:=msoSortBy)>0Thenn=.Foundcol1=2ReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,"\")nm=Right(,Len()-aa)nm1=Left(nm,Len(nm)-4)Ifnm1<>"汇总表"ThenWorkbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookForEachshInSheetss=s&sh.Name&","Nexts=Left(s,Len(s)-1)ar=Split(s,",")UserForm1.ShowForj=0ToUBound(ar1)IfErr.Number=9ThenGoTo100Setsh=wb.Sheets(ar1(j))sh.Activatem=sh.[a65536].End(xlUp).Rowarr=Range(Cells(3,3),Cells(m,3))Sht1.Activatecol1=col1+1Cells(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)=arrNextj100: wb.Closesavechanges:=FalseSetwb=Nothings=IfVarType(arl)=8200ThenErasear1EndIfNextElseMsgBox”该文件夹里没有任何文件”EndIfEndWith[a1].SelectSetmyFs=NothingApplication.ScreenUpdating=TrueEndSubPrivateSubCommandButton1_Click()Fori=0ToListBox1.ListCount-1IfListBox1.Selected(i)=TrueThens=s&ListBox1.List(i)&",”EndIfNextiIfs<>""Thens=Left(s,Len(s)-1)ar1=Split(s,",")MsgBox"你选择了"&sUnloadUserForm1Elsemg=MsgBoxC你没有选择任何工作表！需要重新选择吗？",vbYesNo,^示")Ifmg=6ThenElseUnloadUserForm1EndIfEndIfEndSubPrivateSubCommandButton2_Click()UnloadUserForm1EndSubPrivateSubUserForm_Initialize()WithMe.ListBox1.List=ar ,文本框赋值.ListStyle=1 ‘文本前加选择小方框.MultiSelect=1 '设置可多选EndWithMe.Labell.Caption=Me.Labell.Caption&nmEndSub4,多工作表汇总(字典、数组)‘Data多表汇总0623.xlsSubdbhz()多表汇总DimSht1AsWorksheet,Sht2AsWorksheet,ShtAsWorksheetDimd,k,t,Myr&,Arr,xApplication.ScreenUpdating=FalseApplication.DisplayAlerts=FalseSetd=CreateObject("Scripting.Dictionary")ForEachShtInSheets ’删除同名的表格，获得要增加的汇总表格不重复名字IfInStr(Sht.Name,"-")>0ThenSht.Delete:GoTo100nm=Mid(Sht.[a3],7)d(nm)=""100:NextShtApplication.DisplayAlerts=Truek=d.keysFori=0ToUBound(k)Sheets.Addafter:=Sheets(Sheets.Count)SetSht1=ActiveSheetSht1.Name=Replace(k(i),"/","-") ’增加汇总表，把名字中的"/"(不能用作表名的)改为"-“NextiErasekSetd=NothingForEachShtInSheetsWithSht.ActivateIfInStr(.Name,"-")=0Thennm=Replace(Mid(.[a3],7),"/","-")Myr=.[h65536].End(xlUp).RowArr=.Range("d10:h"&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)EndIfNextk=d.keyst=d.itemsSetSht2=Sheets(nm)Sht2.Activatemyr2=[a65536].End(xlUp).Row+1Ifmyr2<9ThenCells(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)ElseCells(myr2,1).Resize(UBound(k)+1,1)=Application.Transpose(k)Cells(myr2,2).Resize(UBound(t)+1,1)=Application.Transpose(t)EndIfErasekErasetSetd=NothingEndIfEndWithNextShtApplication.ScreenUpdating=TrueEndSub5，多工作簿提取指定数据()‘2011-8-31‘9188-1-1,htmlSubGetData()DimBrrbz(1To200,1To19),Brrgr(1To500,1To23)DimmyFsAs,myfileDimmyPathAsString,$,wbnm$Dimi&,n&,mm&,aa$,nm1$,j&DimSht1AsWorksheet,shAsWorksheet,wb1AsWorkbookApplication.ScreenUpdating=FalseSetwb1=ThisWorkbookwbnm=Left(wb1.Name,Len(wb1.Name)-4)SetSht1=ActiveSheetSht1.[a2:w200]="”aa=Left(Sht1.Name,2)SetmyFs=Application.myPath=ThisWorkbook.Path&"\"WithmyFs.NewSearch.LookIn=myPath.二mso.="*.xls".SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)>0Thenn=.FoundReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)nm1=Split(Mid(,InStrRev(,"\")+1),".")(0)Ifnm1=wbnmThenGoTo200Workbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookForEachshInSheetsIfInStr(sh.Name,aa)Thensh.ActivateIfaa="班子"Thenmm=mm+1Brrbz(mm,1)=[b2].ValueForj=2To18Step2Ifj<10ThenBrrbz(mm,j)=Cells(j/2+34,11).ValueElseBrrbz(mm,j)=Cells(j/2+34,9).ValueEndIfNextGoTo100ElseIf[b2]=""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.Closesavechanges:=FalseSetwb=Nothing200:NextElseMsgBox”该文件夹里没有任何文件”EndIfEndWithIfaa="班子"Then[a2].Resize(mm,19)=BrrbzElse[a2].Resize(mm,23)=BrrgrEndIf[a1].SelectSetmyFs=NothingEndSub‘2011-7-15‘Subpldrsj()'批量导入指定文件的数据DimmyFsAs,myfile,BrrDimmyPath$,$,nm2$Dimi&,j&,n&,aa$,nm$DimSht1AsWorksheet,shAsWorksheetApplication.ScreenUpdating=FalseSetSht1=ActiveSheetSht1.Cells.ClearContentsnm2=ActiveWorkbook.NameSetmyFs=Application.myPath=ThisWorkbook.PathWithmyFsNewSearch.LookIn=myPath.=mso.="*.xls”.SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)>0Thenn=.FoundReDimBrr(1Ton,1To2)ReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=工nStrRev(,"\")nm=Right(,Len()-aa) 带后缀的Excel文件名Ifnm<>nm2Thenj=j+1Workbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookSetsh=wb.Sheets("Sheet1")Brr(j,1)=nmBrr(j,2)=sh.[c3].Valuewb.Closesavechanges:=FalseSetwb=NothingEndIfNextElseMsgBox该文件夹里没有任何文件”EndIfEndWithSht1.Select[a3].Resize(UBound(Brr),2)=BrrSetmyFs=NothingApplication.ScreenUpdating=TrueEndSubSubpldrsj0707(),6387-1-1,html'Report2.xls批量导入指定文件的数据DimmyFsAs,myfileDimmyPathAsString,$,ma&,mc&DimiAsLong,nAsLong,nn&,aa$,nm$,nm1$DimSht1AsWorksheet,shAsWorksheetApplication.ScreenUpdating=FalseSetSht1=ActiveSheet:nn=5Sht1.[b5:e27]=""SetmyFs=Application.myPath=ThisWorkbook.Path&"\data" ’指定的子文件夹内搜索WithmyFs.NewSearch.LookIn=myPath.二mso.="*.xls".SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)>0Thenn=.FoundReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)nm1=split(mid((,"\")+1),".")(0)一句代码代替以下3句'aa=InStrRev(,"\")'nm=Right(,Len()-aa) '带后缀的Excel文件名'nm1=Left(nm,Len(nm)-4) '去除后缀的Excel文件名Ifnm1<>Sht1.NameThenWorkbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookForEachshInSheetssh.Activatema=[b65536].End(xlUp).RowIfma>6Then’第6行是表头Ifma>10Thenma=10’只要取4行数据Forii=7TomaSht1.Cells(nn,2).Resize(1,3)=Cells(ii,2).Resize(1,3).ValueSht1.Cells(nn,5)=Cells(ii,6).Valuenn=nn+1NextiiGoTo100ElseGoTo100EndIfmc=[d65536].End(xlUp).RowIfmc>7Then’第7行是表头Ifmc>11Thenmc=11’只要取4行数据Forii=8TomcCells(ii,Sht1.Cells(nn,2).Resize(1,3)Cells(ii,4).Resize(1,3).ValueSht1.Cells(nn,5)=Cells(ii,8).Valuenn=nn+1NextiiGoTo100ElseGoTo100EndIf100:Nextshwb.Closesavechanges:=FalseSetwb=NothingEndIfNextElseMsgBox”该文件夹里没有任何文件”EndIfEndWith[a1].SelectSetmyFs=NothingApplication.ScreenUpdating=TrueEndSub‘‘sum.xlsSubpldrsj0724()批量导入指定文件的数据DimmyFsAs,myfile,Myr1&,ArrDimmyPath$,$,nm2$Dimi&,j&,n&,nn&,aa$,nm$,nm1$DimSht1AsWorksheet,shAsWorksheetApplication.ScreenUpdating=FalseSetSht1=ActiveSheetMyr1=Sht1.[a65536].End(xlUp).RowArr=Sht1.Range("a3:b"&Myr1)Sht1.Range("b3:b"&Myr1).ClearContentsnm2=Left(ActiveWorkbook.Name,Len(ActiveWorkbook.Name)-4)SetmyFs=Application.myPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.二mso.="*.xls"If.Execute(SortBy:=msoSortBy)>0Thenn=.FoundReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,"\")nm=Right(,Len()-aa)'带后缀的Excel文件名nm1=Left(nm,Len(nm)-4) '去除后缀的Excel文件名Ifnm1<>nm2ThenWorkbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookForEachshInSheetsForj=1ToUBound(Arr)Ifsh.Name=Arr(j,1)Thensh.ActivateSetr1=Range("c:c").Find(sh.Name)nn=r1.RowArr(j,2)=Cells(nn,9)GoTo100EndIfNextjNextsh100:wb.Closesavechanges:=FalseSetwb=NothingEndIfNextElseMsgBox”该文件夹里没有任何文件”EndIfEndWithSht1.Select[b3].Resize(UBound(Arr),1)=Application.Index(Arr,0,2)SetmyFs=NothingApplication.ScreenUpdating=TrueEndSub6，多工作表提取指定数据（数组）Subfpkf()Application.ScreenUpdating=FalseDimMyr&,Arr,yf,x&,Myr1&,r1DimShtAsWorksheetMyr=Sheet1.[b65536].End(xlUp).RowSheet1.Range("c8:h"&Myr).ClearContentsArr=Sheet1.Range("c8:h"&Myr)[j8].Formula="=rc[-9]&""|""&rc[-8]”[j8].AutoFillRange("j8:j"&Myr)Range("j8:j"&Myr)=Range("j8:j"&Myr).ValueForEachShtInSheetsIfSht.Name<>Sheet1.NameThenyf=Left(Sht.Name,Len(Sht.Name)-2)Sht.ActivateMyr1=[a65536].End(xlUp).Row-1Forx=7ToMyr1IfCells(x,1)<>""ThenSetr1=Sheet1.Range("j:j").Find(Cells(x,1)&"I"&Cells(x,2))IfNotr1IsNothingThenArr(r1.Row-7,yf)=Cells(x,"ar")EndIfEndIfNextxEndIfNextSheet1.Activate[c8].Resize(UBound(Arr),UBound(Arr,2))=Arr[j:j].ClearApplication.ScreenUpdating=TrueEndSub7,多工作簿多工作表查询汇总去重复值(字典数组)’详细记录.xls3个工作簿需要都打开Subxxjl()DimSht1AsWorksheet,ShtAsWorksheetDimwb1AsWorkbook,wb2AsWorkbook,wb3AsWorkbookDimi&,Myr2&,Arr2,Myr&,Arr,Myr1&,xm$,yl$Application.ScreenUpdating=FalseSetwb1=ActiveWorkbookSetwb2=Workbooks("购进”)Setwb3=Workbooks("配料”)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=Range("a1:b"&Myr)Forj=1ToUBound(Arr)yl=Arr(j,1)wb1.ActivateForEachSht1InSheetsIfSht1.Name=ylThenSht1.ActivateMyr1=[a65536].End(xlUp).Row+1Cells(Myr1,1)=Arr2(i,1)Cells(Myr1,3)=Arr2(i,3)Cells(Myr1,2)=Arr2(i,4)*Arr(j,2)ExitForEndIfNextNextjGoTo100EndIfNext100:NextiCallqccfApplication.ScreenUpdating=TrueEndSubSubqccf()DimShtAsWorksheet,Myr&,Arr,i&,xDimd,k,t,Arr1,j&Application.ScreenUpdating=FalseForEachShtInSheetsSht.ActivateMyr=[a65536].End(xlUp).RowArr=Range("a2:c"&Myr)Setd=CreateObject("Scripting.Dictionary")IfMyr<3ThenGoTo100Fori=1ToUBound(Arr)x=Arr(i,1)&","&Arr(i,3)IfNotd.exists(x)Thend(x)=Arr(i,2)Elsed(x)=d(x)+Arr(i,2)EndIfNextk=d.keyst=d.itemsReDimArr1(1ToUBound(k)+1,1To3)Forj=0ToUBound(k)Arr1(j+1,1)=Split(k(j),",")(0)Arr1(j+1,3)=Split(k(j),",")(1)Arr1(j+1,2)=t(j)NextjRange("a2:c"&Myr).ClearContents[a2].Resize(UBound(Arr1),3)=Arr1100:Setd=NothingNextApplication.ScreenUpdating=TrueEndSub8，多工作簿对比()Subdgzbdb()'多工作簿对比'by:蓝桥2009-11-7DimmyFsAsDimmyPathAsString,$Dimi&,n&,nm$,mySht1AsWorksheet,shAsWorksheetDimwb1AsWorkbook,yf,j&,m1&Dimm,arr,rlApplication.ScreenUpdating=FalseApplication.DisplayAlerts=FalseOnErrorResumeNextSetwb1=ThisWorkbookSetmyFs=Application.myPath=ThisWorkbook.PathForEachSht1InSheetsIfInStr(Sht1.[a1],，费用明细表”)>0Thennm=Left(Sht1.[a1],Len(Sht1.[a1])-5)Sht1.ActivateWithmyFs.NewSearch.LookIn=myPath.=mso.=nm&".xls”.SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)>0Thenmyfile=.FoundFiles(1)Workbooks.OpenmyfileDimwbAsWorkbookSetwb=ActiveWorkbookSetsh=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)Setr1=Sht1.Range("c:c").Find(arr(j,3))Ifr1IsNothingThenm1=Sht1.[d65536].End(xlUp).RowCells(m1,1).EntireRow.Insertshift:=xlUpCells(m1,1)=Cells(m1-1,1)+1Cells(m1,2)=arr(j,3)Cells(m1,yf+3)=arr(j,6)EndIfNextjwb.Closesavechanges:=FalseSetwb=NothingEndIfEndWithEndIfNextSetmyFs=NothingApplication.DisplayAlerts=TrueApplication.ScreenUpdating=TrueEndSub9,多工作簿汇总（字典）Subpldrwb1123()'合并.xls'导入指定文件的数据DimmyFsAsDimmyPathAsString,$Dimi&,n&,y&,bb,j&,xDimSht1AsWorksheet,shAsWorksheetDimaa,nm$,nm1$,m,Arr,r1,mm&Dimd,k,t,d1,t1Application.ScreenUpdating=Falsemm=8SetSht1=ActiveSheetSht1.[a8:h1000].ClearContentsSetmyFs=Application.myPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.二mso.="*.xls".SearchSubFolders=TrueIf.Execute(SortBy:=msoSortBy)>0Thenn=.FoundReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)=myfile(i)aa=InStrRev(,"\")nm=Right(,Len()-aa)nm1=Left(nm,Len(nm)-4)Ifnm1<>"合并"ThenWorkbooks.Openmyfile(i)DimwbAsWorkbookSetwb=ActiveWorkbookm=[a65536].End(xlUp).RowArr=Range(Cells(8,1),Cells(m,7))Setd=CreateObject("Scripting.Dictionary")Setd1=CreateObject("Scripting.Dictionary")Forj=1ToUBound(Arr)x=Year(Arr(j,1))&"年"&Month(Arr(j,1))&“月”&"|"&Arr(j,2)&"|"&Arr(j,3)&"|"&Arr(j,5)d(x)=d(x)+Arr(j,4)d1(x)=Arr(j,7)Nextk=d.keyst=d.itemst1=d1.itemsSht1.ActivateFory=0ToUBound(k)bb=Split(k(y),"I")Cells(mm,1)=nm1Cells(mm,2)=bb(0)Cells(mm,3)=bb(1)Cells(mm,4)=bb(2)Cells(mm,5)=t(y)Cells(mm,6)=bb(3)Cells(mm,7)=t(y)*bb(3)Cells(mm,8)=t1(y)mm=mm+1Nextwb.Closesavechanges:=FalseSetwb=NothingSetd=NothingSetd1=NothingEndIfNextElseMsgBox"该文件夹里没有任何文件"EndIfEndWith[a1].SelectSetmyFs=NothingApplication.ScreenUpdating=TrueEndSub10,多工作簿多工作表提取数据(DoWhile)’年度汇总.xlsSubndhz()DimArr,myPath$,myName$,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("A1").CurrentRegionForEachshInwb.Sheetsshnm=sh.Namesh.ActivateIfInStr(shnm,"班")>0Thencol=11Elsecol=7EndIfFori=2ToUBound(Arr)IfArr(i,col)=shnmThenm=sh.[a65536].End(xlUp).Row+1Cells(m,1).Resize(1,12)=Application.Index(Arr,i,0)EndIfNextNext.CloseFalseEndWithmyName=DirLoopApplication.ScreenUpdating=TrueEndSub‘Subtqsj()DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&,Myr&,Sht1AsWorksheet,pm$Application.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheet[a2:g1000].ClearContentsfunm="提取数据.xls":m=1myPath=ThisWorkbook.Path&"\"myName=Dir(myPath&"*.xls")DoWhilemyName<>""AndmyName<>funmWithGetObject(myPath&myName)Setwb=Workbooks(myName)ForEachshInwb.Sheetsshnm=sh.Namesh.Activatepm=sh.[a4].ValueMyr=sh.[a65536].End(xlUp).RowArr=sh.Range("b9:e"&Myr)m=m+1WithSht1.Cells(m,1)=myName.Cells(m,2)=pm.Cells(m,3)=shnm.Cells(m,4).Resize(UBound(Arr),4)=ArrEndWithm=m+UBound(Arr)-1Next.CloseFalseEndWithmyName=DirLoopApplication.ScreenUpdating=TrueEndSub'我想要的结果.xlsSubzdgx()DimArr,myPath$,myName$,shAsWorksheetDimm&,funm$,n&,ShtAsWorksheetApplication.ScreenUpdating=Falsefunm="我想要的结果.xls"SetSht=ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle=xlNonemyPath=ThisWorkbook.Path&"\"myName=Dir(myPath&"*.xls")n=2DoWhilemyName<>""AndmyName<>funmWithGetObject(myPath&myName)Setsh=.Sheets("Sheet1")m=sh.[a65536].End(xlUp).RowArr=sh.Range("a2:f"&m)Cells(n,1).Resize(m-1,6)=Arrn=n+m-1.CloseFalseEndWithmyName=DirLoopSht.Range("a2:f"&n-1).Borders.LineStyle=1Application.ScreenUpdating=TrueEndSub‘'汇总工作表.xls2010-2-7Subndhz()DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&,Myr&,Sht1AsWorksheetApplication.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetfunm="汇总工作表.xls":m=1myPath=ThisWorkbook.Path&"\"myName=Dir(myPath&"*.xls")DoWhilemyName<>""AndmyName<>funmWithGetObject(myPath&myName)Setwb=Workbooks(myName)ForEachshInwb.Sheetsshnm=sh.Namesh.ActivateMyr=sh.[a65536].End(xlUp).RowArr=sh.Range("a1:c"&Myr)Fori=1ToUBound(Arr)IfArr(i,3)>50Thenm=m+1Sht1.Cells(m,1).Resize(1,3)=Application.Index(Arr,i,0)Sht1.Cells(m,4)=Arr(i+1,3)Sht1.Cells(m,5)=Arr(i+2,3)Sht1.Cells(m,6)=shnmEndIfNextNext.CloseFalseEndWithmyName=DirLoopApplication.ScreenUpdating=TrueEndSub‘Subndhz()DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,col%,i&,Myr&,Sht1AsWorksheetApplication.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetfunm="汇总工作表.xls":m=1myPath=ThisWorkbook.Path&"\"myName=Dir(myPath&"*.xls")DoWhilemyName<>""AndmyName<>funmWithGetObject(myPath&myName)Setwb=Workbooks(myName)ForEachshInwb.Sheetsshnm=sh.Namesh.ActivateMyr=sh.[a65536].End(xlUp).RowArr=sh.Range("a1:c"&Myr)Fori=1ToUBound(Arr)IfArr(i,3)>50Thenm=m+1Sht1.Cells(m,1).Resize(1,3)=Application.Index(Arr,i,0)Sht1.Cells(m,4)=Arr(i+1,3)Sht1.Cells(m,5)=Arr(i+2,3)Sht1.Cells(m,6)=shnmEndIfNextNext.CloseFalseEndWithmyName=DirLoopApplication.ScreenUpdating=TrueEndSub‘9493-1-1,htmlSubndhz()’设置工作表在此处要用Sheets("汇总")格式DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheetDimm&,funm$,shnm$,n%,i&,wb1AsWorkbookApplication.ScreenUpdating=FalseSetwb=ThisWorkbookfunm="汇总.xls":n=1myPath=ThisWorkbook.Path&"\"myName=Dir(myPath&"*.xls")wb.Sheets("汇总").[a2:e100].ClearDoWhilemyName<>""AndmyName<>funmWithGetObject(myPath&myName)Setwb1=Workbooks(myName)Setsh=wb1.Sheets("Sheet1")m=sh.[a65536].End(xlUp).RowWithwb.Sheets("汇总")n=n+1.Cells(n,1)=sh.[b2].Value.Cells(n,2)=sh.[c2].Value.Cells(n,3)=Application.Sum(sh.[e2].Resize(m-1,1)).Cells(n,4)=Application.Sum(sh.[f2].Resize(m-1,1)).Cells(n,5)=Application.Sum(sh.[g2].Resize(m-1,1))EndWith.CloseFalseEndWithmyName=DirLoopwb.Sheets("汇总").Range("a2:e"&n).Borders.LineStyle=1Application.ScreenUpdating=TrueEndSub,0459-1-1,html‘ABC.xls 2010-5-28Subdgzbsj()DimArr,i&,sh$,n&,myPath$,shnm$,nm$,ad$DimShtAsWorksheet,m&,Arr1,r1OnErrorResumeNextApplication.ScreenUpdating=FalsemyPath=ThisWorkbook.Path&"\"sh=Dir(myPath&"*.xls")WhileNotLen(sh)=0Ifsh<>ThisWorkbook.NameThenWithGetObject(myPath&sh)SetSht=.Sheets("Sheet1"),要用set以后才能取到数据m=Sht.[b65536].End(xlUp).RowArr=Sht.Range("b3:e"&m)Arr1=Sht.Range("b4:e"&m)shnm=Left(sh,Len(sh)-4)Fori=1ToUBound(Arr,2)nm=Arr(1,i)Sheets(nm).ActivateSetr1=Cells.Find(shnm,,,1)IfNotr1IsNothingThenRange(r1.Address).Offset(1,0).Resize(UBound(Arr1),1)Application.Index(Arr1,0,i)EndIfNextEndWithEndIfsh=DirWendApplication.ScreenUpdating=TrueEndSub‘2011-7-5‘Subndhz()DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheetDimfunm$,nm$,n%,wb1AsWorkbook,r1,col%,Myr&Application.ScreenUpdating=FalseSetwb=ThisWorkbookfunm=噫表.xls":n=1myPath=ThisWorkbook.Path&"\"myName=Dir(myPath&"*.xls")wb.Sheets("Sheet1").Cells.ClearContents[a2]=，产品名”DoWhilemyName<>””IfmyName<>funmThenWithGetObject(myPath&myName)nm=Left(myName,Len(myName)-4)Setwb1=Workbooks(myName)Setsh=wb1.Sheets("Sheet1")Arr=sh.[a1].CurrentRegionWithwb.Sheets("Sheet1")Setr1=.Rows(2).Find(nm,,,1)IfNotr1IsNothingThencol=r1.ColumnElsecol=[iv2].End(xlToLeft).Column+1Cells(2,col)=nmEndIfFori=2ToUBound(Arr)Setrl=.[a:a].Find(Arr(i,1),,,1)IfNotrlIsNothingThen.Cells(r1.Row,col)=Arr(i,2)ElseMyr=.[a65536].End(xlUp).Row+1.Cells(Myr,1)=Arr(i,1).Cells(Myr,col)=Arr(i,2)EndIfNextEndWith.CloseFalseEndWithEndIfmyName=DirLoopApplication.ScreenUpdating=TrueEndSub11，多工作簿提取指定数据(GetOpen),汇总表.xls‘PrivateSubCommandButton1_Click()DimtmpAsString,AsInteger,cAsRangeDimmyWorkbookAsWorkbook,tmpAsVarian,tmpAsLongDimfAsRange,上述红字必须声明为Variant,否则下面的Ubound要出错tmp=Application.GetOpen("DataFile(*.xls),*.xls",,'确定文件"，，True)IfVarType(tmp)=vbBooleanThenExitSubElseApplication.ScreenUpdating=FalseApplication.StatusBar="数据处理中，请稍等…"Application.DisplayAlerts=FalseSetf=[a65536].End(xlUp)Fortmp=1ToUBound(tmp)Application.StatusBar=tmp&"/"&UBound(tmp)&"处理中"tmp=tmp(tmp)SetmyWorkbook=Workbooks.Open(tmp,0,vbReadOnly)WithmyWorkbookSetc=.Worksheets(1).Range("b:B").Find("销售额")’找到B列中带销售额字样的单元格Setf=f.Offset(1,0)f.Value=Left(.Name,Len(.Name)-4)填入文件名f.Offset(0,1).Value=c.Offset(0,1).Value填入销售额的数字.CloseFalseEndWithNexttmpEndIfApplication.StatusBar=FalseApplication.DisplayAlerts=TrueEndSub12,多工作表汇总(字典)’1231228.xls‘8738-1-1,html模块1：Publicm%,k1PrivateSubWorkbook_Open()Dimd,k,t,Myr&,Arr,i&Setd=CreateObject("Scripting.Dictionary")WithSheet3Myr=.[a65536].End(xlUp).RowArr=.Range("a2:e"&Myr)Fori=1ToUBound(Arr)d(Arr(i,1))=""Nextk=d.keysWithSheet1.[b1].Vilidation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=Join(d.keys,",")EndWithd.RemoveAllSetd=CreateObject("Scripting.Dictionary")Fori=1ToUBound(Arr)d(Arr(i,4))=""Nextm=d.Countk1=d.keysEndWithEndSubPrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Count>1ThenExitSubIfTarget.Address<>"$B$1"ThenExitSubDimd,k,t,Arr,i&,Myr&,x,yf,j&,Arr1Dimii&,lj,zb,ljs,cp,j1%,y,jj%Setd=CreateObject("Scripting.Dictionary")yf=Target.ValueWithSheet2Myr=.[a65536].End(xlUp).RowArr=.Range("a2:e"&Myr)Fori=1ToUBound(Arr)x=Arr(i,1)&"I"&Arr(i,4)d(x)=d(x)+Arr(i,5)Nextk=d.keyst=d.itemsReDimArr1(1Tom,1To7)Forj=0ToUBound(k1)Forj1=0ToUBound(k)y=Val(Split(k(j1),"I")(0))cp=Split(k(j1),"I")(1)Ifcp=k1(j)Andy=yfThenArr1(j+1,1)=k1(j)Arr1(j+1,3)=t(j1)'本月发货EndIfIfcp=k1(j)Andy<yf+1Thenlj=lj+t(j1)'累计发货EndIfNextArr1(j+1,6)=lj累计发货lj=0NextEndWithd.RemoveAllSetd=CreateObject("Scripting.Dictionary")WithSheet3Myr=.[a65536].End(xlUp).RowArr=.Range("a2:e"&Myr)Fori=1ToUBound(Arr)x=Arr(i,1)&"I"&Arr(i,4)d(x)=d(x)+Arr(i,5)Nextk=d.keyst=d.itemsForj=0ToUBound(kl)Forjl=0ToUBound(k)y=Val(Split(k(j1),"l")(0))cp=Split(k(j1),"|")(1)Ifcp=k1(j)Andy=yfThenArr1(j+1,2)=t(j1)'本月指标Forii=1ToUBound(k)+1zb=zb+t(ii-1)本年指标NextArr1(j+1,5)=zb本年指标zb=0ExitForEndIfNextNextEndWithd.RemoveAllSetd=CreateObject("Scripting.Dictionary")WithSheet4Myr=.[a65536].End(xlUp).RowArr=.Range("a2:e"&Myr)Fori=1ToUBound(Arr)x=Arr(i,1)&"I"&Arr(i,4)d(x)=d(x)+Arr(i,5)Nextk=d.keyst=d.itemsForj=0ToUBound(k1)Forj1=0ToUBound(k)y=Val(Split(k(j1),"I")(0))cp=Split(k(j1),"I")(1)Ifcp=k1(j)Andy=yfThenArr1(j+1,4)=t(j1)'上年发货EndIfIfcp=k1(j)Andy<yf+1Thenljs=ljs+t(j1)'累计发货EndIfNextArr1(j+1,7)=ljs累计发货ljs=0NextEndWithSheet1.[c4].Resize(UBound(Arr1),7).ClearContentsSheet1.[c4].Resize(UBound(Arr1),7)=Arr1EndSub13，多工作表不同产量总”汇总（字典）’计算多个表相同名称的总重量0108.xlsPrivateSubCommandButton1_Click()Dimnm$,nm1$,i&,d,stAsWorksheet,r1,ad$,sul,tnm=”各机组投产数量”nm1="材料调价分类明细”Setd=CreateObject("scripting.dictionary")Fori=3To[b65536].End(3).Rowd(""&Cells(i,2))=0'不重复材料重量置0NextiForEachstInSheetsIfst.Name<>nm1Andst.Name<>nmAndst.Name<>“data"Andst.Name<>"提示"ThenSetr1=Sheets(nm).Cells.Find(st.Name,,,1)IfNotr1IsNothingThenad=r1.Address'表格名的地址sul=Sheets(nm).Range(ad).Offset(1,0)'投产的数量Ifsul<>0ThenFori=3Tost.[b65536].End(3).Rowd("&st.Cells(i,3))=d(""&st.Cells(i,3))+st.Cells(i,4)*sulNextiEndIfEndIfEndIfNextstt=d.items[f3].Resize(d.Count,1)=Application.Transpose(t)ExitSubFori=3To[b65536].End(3).RowCells(i,6)=d(""&Cells(i,2))NextiEndSub14,多工作簿汇总（和Dir）‘2010-5-5‘汇总表.xls__解决一个月的汇总Subrmxb0505()DimmyFsAsDimmyPathAsString,$Dimi&,n&,r%,Arr1(),rq,sl,rr,yy,Myc%DimSht1AsWorksheet,shAsWorksheet,yg$,bbDimaa,nm1$,m,arr,r1,j&,Rmx,Ymx,RmxhjDimjs,ks,x,y,col%,nm$Application.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetMyc=[iv2].End(xlToLeft).ColumnRange("b3",Cells(33,Myc)),ClearContentsRmx=Range("b3",Cells(33,Myc))Sheet2.ActivateYmx=