ExcelVBA_多工作簿多工作表汇总情况实例集锦1

1，多工作 表 关于同志近三年现实表现材料材料类招标技术评分表图表与交易pdf视力表打印pdf用图表说话 pdf 汇总(Consolidate)‘.excelpx./dispbbs.asp?boardID=5&ID=110630&page=1’两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。SubConsolidateWorkbook()DimRangeArray()AsStringDimbkAsWorksheetDimshtAsWorksheetDimWbCountAsIntegerSetbk=Sheets("汇总")WbCount=Sheets.CountReDimRangeArray(1ToWbCount-1)ForEachshtInSheetsIfsht.Name<>"汇总"Theni=i+1RangeArray(i)="'"&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")WithWorksheets("汇总").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，多工作簿汇总(FileSearch)‘club.excelhome.net/thread-442007-1-1.html###'help\汇总表.xlsSubpldrwb0531()汇总表.xls'导入指定文件的数据DimmyFsAsFileSearchDimmyPathAsString,Filename$DimiAsLong,nAsLongDimSht1AsWorksheet,shAsWorksheetDimaa,nm$,nm1$,m,arr,r1,col1%Application.ScreenUpdating=FalseSetSht1=ActiveSheetSetmyFs=Application.FileSearchmyPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename="*.xls"If.Execute(SortBy:=msoSortByFileName)>0Thenn=.FoundFiles.Countcol1=2ReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)Filename=myfile(i)aa=InStrRev(Filename,"\")nm=Right(Filename,Len(Filename)-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列依次导入DimmyFsAsFileSearchDimmyPathAsString,Filename$DimiAsLong,nAsLongDimSht1AsWorksheet,shAsWorksheetDimaa,nm1$,m,arr,r1,col1%Application.ScreenUpdating=FalseOnErrorResumeNextSetSht1=ActiveSheetSetmyFs=Application.FileSearchmyPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename="*.xls"If.Execute(SortBy:=msoSortByFileName)>0Thenn=.FoundFiles.Countcol1=2ReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)Filename=myfile(i)aa=InStrRev(Filename,"\")nm=Right(Filename,Len(Filename)-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(ar1)=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=MsgBox("你没有选择任何工作表！需要重新选择吗？",vbYesNo,"提示")Ifmg=6ThenElseUnloadUserForm1EndIfEndIfEndSubPrivateSubCommandButton2_Click()UnloadUserForm1EndSubPrivateSubUserForm_Initialize()WithMe.ListBox1.List=ar‘文本框赋值.ListStyle=1‘文本前加选择小方框.MultiSelect=1‘设置可多选EndWithMe.Label1.Caption=Me.Label1.Caption&nmEndSub4，多工作表汇总(字典、数组)‘club.excelhome.net/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D1‘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，多工作簿提取指定数据(FileSearch)‘2011-8-31‘club.excelhome.net/thread-759188-1-1.htmlSubGetData()DimBrrbz(1To200,1To19),Brrgr(1To500,1To23)DimmyFsAsFileSearch,myfileDimmyPathAsString,Filename$,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.FileSearchmyPath=ThisWorkbook.Path&"\"WithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename="*.xls".SearchSubFolders=TrueIf.Execute(SortBy:=msoSortByFileName)>0Thenn=.FoundFiles.CountReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)Filename=myfile(i)nm1=Split(Mid(Filename,InStrRev(Filename,"\")+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‘club.excelhome.net/viewthread.php?tid=741341&pid=5036524&page=1&extra=Subpldrsj()'批量导入指定文件的数据DimmyFsAsFileSearch,myfile,BrrDimmyPath$,Filename$,nm2$Dimi&,j&,n&,aa$,nm$DimSht1AsWorksheet,shAsWorksheetApplication.ScreenUpdating=FalseSetSht1=ActiveSheetSht1.Cells.ClearContentsnm2=ActiveWorkbook.NameSetmyFs=Application.FileSearchmyPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename="*.xls".SearchSubFolders=TrueIf.Execute(SortBy:=msoSortByFileName)>0Thenn=.FoundFiles.CountReDimBrr(1Ton,1To2)ReDimmyfile(1Ton)AsStringFori=1Ton'带后缀myfile(i)=.FoundFiles(i)Filename=myfile(i)aa=InStrRev(Filename,"\")nm=Right(Filename,Len(Filename)-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()'club.excelhome.net/thread-456387-1-1.html'Report2.xls'批量导入指定文件的数据DimmyFsAsFileSearch,myfileDimmyPathAsString,Filename$,ma&,mc&DimiAsLong,nAsLong,nn&,aa$,nm$,nm1$DimSht1AsWorksheet,shAsWorksheetApplication.ScreenUpdating=FalseSetSht1=ActiveSheet:nn=5Sht1.[b5:e27]=""SetmyFs=Application.FileSearchmyPath=ThisWorkbook.Path&"\data"‘指定的子文件夹搜索WithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename="*.xls".SearchSubFolders=TrueIf.Execute(SortBy:=msoSortByFileName)>0Thenn=.FoundFiles.CountReDimmyfile(1Ton)AsStringFori=1Tonmyfile(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<>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=8TomcSht1.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‘club.excelhome.net/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D2‘sum.xlsSubpldrsj0724()'批量导入指定文件的数据DimmyFsAsFileSearch,myfile,Myr1&,ArrDimmyPath$,Filename$,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.FileSearchmyPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename="*.xls"If.Execute(SortBy:=msoSortByFileName)>0Thenn=.FoundFiles.CountReDimmyfile(1Ton)AsStringFori=1Tonmyfile(i)=.FoundFiles(i)Filename=myfile(i)aa=InStrRev(Filename,"\")nm=Right(Filename,Len(Filename)-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，多工作表提取指定数据（数组）‘excel.aa.topzj./viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718Subfpkf()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)&"|"&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，多工作簿多工作表查询汇总去重复值（字典数组）‘club.excelhome.net/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D1’详细 记录 混凝土 养护记录下载土方回填监理旁站记录免费下载集备记录下载集备记录下载集备记录下载 .xls‘3个工作簿需要都打开Subxxjl()DimSht1AsWorksheet,ShtAsWorksheetDimwb1AsWorkbook,wb2AsWorkbook,wb3AsWorkbookDimi&,Myr2&,Arr2,Myr&,Arr,Myr1&,xm$,yl$Application.ScreenUpdating=FalseSetwb1=ActiveWorkbookSetwb2=Workbooks("购进")