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

...1，多工作表汇总（Consolidate）‘=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()AsString...DimbkAsWorkbookDimshtAsWorksheetDimWbCountAsIntegerWbCount=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）‘‘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=*.xlsIf.Execute(SortBy:=msoSortByFileName)0Thenn=.FoundFiles.Countcol1=2ReDimmyfile(1Ton)AsString...Fori=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=ActiveSheet...SetmyFs=Application.FileSearchmyPath=ThisWorkbook.PathWithmyFs.NewSearch.LookIn=myPath.FileType=msoFileTypeNoteItem.Filename=*.xlsIf.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=Nothing...s=IfVarType(ar1)=8200ThenErasear1EndIfNextElseMsgBox该文件夹里没有任何文件EndIfEndWith[a1].SelectSetmyFs=NothingApplication.ScreenUpdating=TrueEndSubPrivateSubCommandButton1_Click()Fori=0ToListBox1.ListCount-1IfListBox1.Selected(i)=TrueThens=s&ListBox1.List(i)&,EndIfNextiIfsThens=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，多工作表汇总（字典、数组）‘=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+1Ifmyr29ThenCells(9,1).Resize(1,2)=Array(PartNo.,TTLQty)Cells(10,1).Resize(UBound(k)+1,1