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

合集下载

Excel高效办公VBA代码-快速将多个工作簿合并到一张工作表

快速将多个工作簿合并到一张工作表作者原著，尊重成果，侵权必究一、应用场景我们很多时候，导出数十份excel格式，文本格式的文档；这些文档的格式一致，我们需要将它们合并到一张工作表中，而且合并后不会重复表头。

通常要一张张打开，复制，耗时耗力。

利用vba代码将可以一键实现将多份文件，一秒钟快速合并到一张工作表中。

二、示例1.要求：需要该工作簿的所有表格，单独保存为工作簿2.做法：利用vba代码，实现一键将多份工作簿，合并到一张工作表内，并在最后一列说明工作表的名称，以作标识需要这些工作簿合并到一张工作表中（格式相同）新建一份要合并到的工作簿，点击自定义宏中“合并文件”按钮输入要合并文件的路径输入要合并的格式实现合并三、重点：vba源代码如下（具有通用性）Sub 合并文件需新建()On Error Resume NextDim MyPath, MyNameDim Wb As Workbook, WbN As StringDim G As Long, Num As Long, i, jApplication.ScreenUpdating = FalseMyPath = InputBox("请输入要合并的文件路径")gs = InputBox("请输入文件格式，如：xls")If MyPath <> "" And gs <> "" ThenMyName = Dir(MyPath & "\" & "*." & gs & "*") '注意修改文件格式Num = 0Set Wb = Workbooks.Open(MyPath & "\" & MyName)For G = 1 To Sheets.CountWb.Sheets(G).UsedRange.Copy Workbooks(1).Sheets(1).Cells(Workbooks(1). _Sheets(1).Range("B1048576").End(xlUp).Row, 1)NextMyName = DirDo While MyName <> ""Set Wb = Workbooks.Open(MyPath & "\" & MyName)Num = Num + 1For G = 1 To Sheets.Counti = Wb.Sheets(G).Range("B1048576").End(xlUp).Rowj = Wb.Sheets(G).Cells(1, 16384).End(xlToLeft).Column '不复制表头Wb.Sheets(G).Range(Cells(2, 1), Cells(i, j)).Copy Workbooks(1).Sheets(1) _.Cells(Workbooks(1).Sheets(1).Range("B1048576").End(xlUp).Row + 1, 1) NextWbN = WbN & Chr(13) & Wb.CloseMyName = DirLoopWorkbooks(1).Sheets(1).ActivateActiveSheet.Range("a1").SelectSelection.AutoFilterActiveSheet.Range("a2").SelectActiveWindow.FreezePanes = TrueApplication.DisplayAlerts = FalseWorkbooks(1).SaveApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "共合并了" & Num & "个工作薄下的全部工作表。

VBA对多个工作簿进行合并计算（求和）一例

VBA对多个工作簿进行合并计算（求和）一例VBA对多个工作簿进行合并计算（求和）一例Excel中的合并计算可以对多个工作表的对应项目进行求和、求平均值等计算，但如果需要合并计算的工作表较多，特别是这些工作表位于不同的工作簿内时，逐一选择数据源显得较为繁琐。

用VBA中的Range.Consolidate方法可以快速地对多个结构相似的工作表进行合并计算，但如果表格内包含有非数值类型的数据列，合并计算会忽略这些列。

例如下图为某个图书销售点1至12月的图书销售记录，销售数量位于D至O列，其中B列和C列为与A列对应的数据，无需参与合并计算，但必须在汇总表中列出。

各销售点都有一个类似的销售表格，每个分表列出的图书数量不等，图书名称也不尽相同。

现在需要对各销售点的销售表格中D至O列的销售数量按照A列图书名称进行合计，求出总的销售数量。

如果直接使用合并计算，Excel会忽略B列文本，同时对C列（单价）也进行合并计算，显然不符合要求。

这时使用VBA中的Dictionary对象，可以解决这一问题，代码如下：Sub SumWorkbooks()Dim ThePath As String, TheFile As StringDim d As Object, Wbk As WorkbookDim i As Integer, j As Integer, k As IntegerDim Arr1(11), Arr2(), Arr3(), dkOn Error Resume NextApplication.ScreenUpdating = FalseSet d = CreateObject("scripting.dictionary")ThePath = ThisWorkbook.Path & "\"TheFile = Dir(ThePath & "*.xls")Do While TheFile <> ""If TheFile <> ThenSet Wbk = GetObject(ThePath & TheFile)With Wbk.Worksheets(1)For i = 2 To .Range("A65536").End(xlUp).Row'将D至O列数值赋值给Arr1For j = 0 To 11Arr1(j) = .Cells(i, j + 4).ValueNext jIf Not d.exists(.Range("A" & i).Value) Then'key对应一个数组d.Add .Range("A" & i).Value, Arr1'将不能求和的数据赋值给Arr2ReDim Preserve Arr2(1 To 2, 1 To k + 1)For j = 1 To 2Arr2(j, k + 1) = .Cells(i, j + 1)Next jk = k + 1ElseFor j = 0 To 11'若数据存在则D至O列数值对应合计到Arr1中的每个元素Arr1(j) = d(.Range("A" & i).Value)(j) + Arr1(j)Nextd(.Range("A" & i).Value) = Arr1End IfNextEnd WithWbk.Close FalseEnd IfTheFile = Dir '当前文件夹内的下一个工作簿Loop'输出With ThisWorkbook.Worksheets(1).Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)dk = d.keysReDim Arr3(1 To d.Count, 1 To 12)For i = 0 To d.Count - 1For j = 0 To 11Arr3(i + 1, j + 1) = d(dk(i))(j)Next jNext i.Range("D2:O" & d.Count + 1).Value = Arr3.Range("B2:C" & d.Count + 1).Value = Application.Transpose(Arr2)End WithSet d = NothingApplication.ScreenUpdating = TrueEnd Sub在汇总表中按Alt+F11，打开VBA编辑器，单击菜单“插入→模块”，粘贴上述代码并运行，即可对汇总工作簿所在的文件夹内的其他所有工作簿的第一个工作表进行合并求和，无需打开各个需要汇总的工作簿。

如何使用ExcelVBA将多个工作簿的全部工作表合并到一个工作簿中

如何使用ExcelVBA将多个工作簿的全部工作表合并到一个工作簿中本文转载自公众号：Office学霸办公软件，作者：Office学霸。

本文著作权归原创作者所有，本人收藏此文仅作为学习之用，不作其他目的，如有侵权请联系我删除。

在一些操作中，往往会需要将多个工作簿进行合并。

一般的操作方法都是打开两个工作簿，然后选中需要移动的工作表，右键单击以后选择“移动或复制”。

接下来在新的窗口里面进行设置就可以了。

这种方法适合在移动数量较少的工作表的时候使用。

如果有很多的工作簿，都需要进行移动的话，一个一个打开然后再操作肯定是比较麻烦耗时的。

这时就可以使用VBA来批量进行操作。

如图，现在在一个文件夹里面有几个工作簿，里面分别有不同数量的工作表。

另外还有一个启用宏的汇总表。

下面就需要使用VBA将工作簿1-3汇总到那个总表中。

打开汇总工作簿，然后运行以下代码：••••••••••••••Sub MergeWorkbook() Application.ScreenUpdating = False Path = 'C:\Users\Administrator\Desktop\新建文件夹' Filename = Dir(Path & '\*.xlsx') While Filename <> '' Set wb = Workbooks.Open(Path & '\' & Filename) For Each Sheet In ActiveWorkbook.Sheets i = Workbooks('汇总.xlsm').Sheets.Count Sheet.Copy After:=Workbooks('汇总.xlsm').Sheets(i) Next Sheet wb.Close Filename = Dir WendEnd Sub运行以后其他工作簿里面的工作表就全部复制到汇总工作簿中了。

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

Excel VBA_多工作簿多工作表汇总实例集锦excelvba_多工作簿多工作表汇总实例集锦1，多工作表汇总（consolidate）dimrangearray()asstringdimbkasworksheetdimshtasworksheetdimwbcountasintegerset bk=sheets(\汇总\wbcount=sheets.countredimrangearray(1towbcount-1)foreachshtinsheets<>\汇总\i=i+1rangearray(i)=\sht.range(\endifnextbk.range(\[a1].value=\姓名\endsubsubsumdemo()dimarrasvariantarr=array(\一月!r1c1:r8c5\二月!r1c1:r5c4\三月!r1c1:r9c6\withworksheets(\汇总\.consolidatearr,xlsum,true,true.value=\姓名\endwithendsub2，多工作簿汇总（consolidate）‘多工作簿汇总subconsolidateworkbook()dimrangearray()asstringdimbkasworkbookdimshtasworksheetdimwbcountasintegerwbcount=workbooks.countredimrangearray(1towbcount-1)foreachbkinworkbooks'在所有工作簿中循环ifnotbkisthisworkbookthen'非代码所在工作簿setsht=bk.worksheets(1)'提及工作簿的第一个工作表i=i+1rangearray(i)=\sht.range(\endifnextworksheets(1).range(\rangearray,xlsum,true,trueendsub3，多工作簿汇总（filesearch）'导入指定文件的数据dimmyfsasfilesearchdimmypathasstring,filename$dimiaslong,naslongdimsht1asworksheet,shasworksheetdimaa,nm$,nm1$,m,arr,r1,col1%application.scree nupdating=falsesetsht1=activesheetsetmyfs=application.filesearchmypath=thisworkbook.pathwithmyfs.newsearch.lookin=mypath.filetype=msofiletypenoteitem.filename=\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<>\汇总表\workbooks.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=nothing endifnextelsemsgbox\该文件夹里没任何文件\endifendwith[a1].selectsetmyfs=nothingapplication.screenupdating=trueendsub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能publicar,ar1,nm$subpldrwb0531()'汇总表.xls'引入选定文件的数据（预设工作表1的数据）'轻易从c列依次引入dimmyfsasfilesearchdimmypathasstring,filename$dimiaslong,naslongdimsht1asworksheet,shasworksheetdimaa,nm1$,m,arr,r1,col1%application.screenupd ating=falseonerrorresumenextsetsht1=activesheetsetmyfs=application.filesearchmypath=thisworkbook.pathwithmyfs.newsearch.lookin=mypath.filetype=msofiletypenoteitem.filename=\if.execute(sortby:=msosortbyfilename)>0thenn=.foundfiles.count\+2,col1))100:col1=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<>\汇总表\workbooks.openmyfile(i)dimwbasworkbooksetwb=activeworkbookforeachshinsheetss=s&&\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=c ol1+1cells(2,col1)=sh.[a1]cells(3,col1).formular1c1=\&nm&\&ar1(j)&‘显示引用的工作簿工作表及单元格地址cells(3,col1).auto fillrange(cells(3,col1),cells(ubound(arr)‘cells(3,col1).res ize(ubound(arr),1)=arrnextjwb.closesavechanges:=falsesetwb=nothings=\ifvartype(ar1)=8200thenerasear1endifnextelsemsgbox\该文件夹里没任何文件\endifendwith[a1].selectsetmyfs=nothingapplication.screenupdating=trueendsubiflistbox1.selected(i)=truethens=s&listbox1.list(i)&\endifnextiifs<>\s=left(s,len(s)-1)ar1=split(s,\msgbox\你挑选了\unloaduserform1elsemg=msgbox(\你没有选择任何工作表！需要重新选择吗？ifmg=6thenelseunloaduserform1endifendifendsubendsubprivatesubuserform_initialize()withme.listbox1.list=ar‘文本框赋值.liststyle=1‘文本ka挑选大方框.multiselect=1‘设置可以多挑选\提示\。

使用VBA合并多个Excel工作簿的几个例子 MY

使用VBA合并多个Excel工作簿的几个例子将许多个工作簿中的工作表合并到一个工作薄中,然后对数据进行统计计算,举了几种合并的案例。

Sub 合并工作簿()Application.DisplayAlerts = False '关闭提示窗口shes = Application.SheetsInNewWorkbook '工作簿中包含工作表数Application.SheetsInNewWorkbook = 1 '生成的新工作簿中只有一个工作表Set newbok = Workbooks.Add '生成新工作簿Set newshe = newbok.Worksheets(1) '新工作表s = 1 '从新工作表的第一行写入数据na = Dir("d:\123\*.xls") '需要合并的所有工作表都要事先保存在D盘time文件夹下Do While na <> ""Set wb = Application.Workbooks.Open("d:\123\" & na)wb.Worksheets(1).UsedRange.Copy '复制数据newbok.ActivateCells(s, 1).SelectActiveSheet.Paste '执行粘贴s = edRange.Rows.Count + 1Cells(s, 1) = '写入数据所属的工作簿名字s = s + 1wb.Close '关闭工作簿na = Dir() '取下一个工作簿LoopApplication.SheetsInNewWorkbook = shesApplication.DisplayAlerts = TrueRange("a1").SelectEnd Sub///把多个工作簿中的第一个工作表中的数据合并到一个工作簿的一个工作表中Sub Com()Dim MyPath, MyName, A WbNameDim Wb As Workbook, WbN As StringDim G As LongDim Num As LongDim BOX As StringApplication.ScreenUpdating = FalseMyPath = ActiveWorkbook.PathMyName = Dir(MyPath & "\" & "*.xls")A WbName = Num = 0Do While MyName <> ""If MyName <> A WbName ThenSet Wb = Workbooks.Open(MyPath & "\" & MyName)Num = Num + 1With Workbooks(1).ActiveSheet.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)For G = 1 To Wb.Sheets.CountWb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)NextWbN = WbN & Chr(13) & Wb.Close FalseEnd WithEnd IfMyName = DirLoopRange("A1").SelectMyName = DirLoopRange("A1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & Num & "个工作薄下的全部工作表。

VBA处理Excel中的多工作簿和多工作表

VBA处理Excel中的多工作簿和多工作表VBA（Visual Basic for Applications）是一种编程语言，可以用来处理Excel中的多个工作簿和工作表。

它提供了丰富的功能，可以自动进行数据处理、格式调整、图表生成等任务。

在本文中，我将详细介绍如何使用VBA处理Excel中的多个工作簿和工作表。

首先，我们先了解一下VBA中的对象和方法。

在Excel中，有几个重要的对象需要我们熟悉：Application对象、Workbook对象和Worksheet对象。

Application对象表示Excel应用程序本身，Workbook对象表示一个Excel工作簿，而Worksheet对象表示一个工作簿中的一个工作表。

我们可以使用这些对象的方法来操作和处理Excel中的数据。

接下来，我将分别介绍如何处理多个工作簿和多个工作表的情况。

处理多个工作簿：1. 打开工作簿：使用Workbooks.Open方法可以打开一个或多个工作簿。

例如，可以使用以下代码打开一个名为"Book1.xlsx"的工作簿：```Workbooks.Open("C:\Users\UserName\Documents\Book1.xlsx")```2. 复制数据：使用Workbook对象的Copy方法可以将一个工作簿的数据复制到另一个工作簿。

例如，可以使用以下代码将"Book1.xlsx"中的数据复制到"Book2.xlsx"中的Sheet1：Workbooks("Book1.xlsx").Sheets("Sheet1").UsedRange.CopyWorkbooks("Book2.xlsx").Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues```3. 保存工作簿：使用Workbook对象的Save方法可以保存工作簿。

VBA实现Excel多表格汇总

件、若仅川于Ｏｆｉｃｅ２００７及以卜版本，＿『修改第１０和３０句．．
图２
相信操作Ｅｘｔ－ｅｌ的川户大都会遇上多个表格汇总，往往是在同一个史什巾插入多个Ｓｈｅｅｔｓ并复制上分别要汇总的表格，再川ｔ “∑”或公式及复制完成有多个文件、多个表格及多个数据块汇总时如图１分别是总公司存一个Ｔ作簿史件的３个汇总表．其中各数据块（Ａ—Ｃ数据块）的元格数据为从图２的 “分公司１．ｘｌｓ”一 “分公司６．ｘｌｓ” 中报表（报表ｌ、报表２、报表３）对应单元格累加的汇总，手丁编辑时通常是在Ａ数据块的左上单元格输入 “＝『分公司１．ｘｌｓ］报表ｌ！Ｂ４＋
４０ＥｎｄＩｆ５０Ｆｏｒｉ＝２ＴｏＬａｓｔＳｈｅｅｔｓ
６０Ｆｏｒｊ：１Ｔｏ７７０ＴＳｔｒ＝Ｍｉｄ（ＩＶ：７ｊ）
＿
８０ＩｆＩｎｓｔｒ（Ｒａｎｇｅ（“ｄ＆ｉ），Ｔ—Ｓｔｒ）Ｔｈｅｎ９０ＭｓｇＢｏｘ”表名错误！ＩＩ：Ｅｎｄ１Ｏ０ＥｎｄＩｆ１１ＯＮｅｘｔ１２００ｋ＝Ｔｒｕｅ１３０ＦｏｒＥａｃｈｊｉｎＳｈｅｅｔｓ１４０ＩｆＴＳｔｒ＝ｊ．ＮａｍｅＴｈｅｎＯｋ＝一
１ｉ分公司名是否汇总
量一ｉ盆蛰蜀 — 经ｉＬ盘——一
ｓ公司２待忙总
哇ｉ分公司３ｇ１分公司４
椿｝ｆ息待汇总
６｝分公司５７：分公司６８１
椿汇总祷奠
譬跬鞠黼龋瓣隅糟瓣麟罐 §：
４０Ｆｏｒｉ＝１ＴＯ９

用VBA代码快速实现多表数据汇总

Excel多个工作表合并至一个工作表！效果如下所示：
要求汇总至一个工作表
1多个工作表
表一数据：
姓名定位性别程咬金坦克男刘禅坦克男墨子坦克男亚瑟坦克男钟无艳坦克女
表二数据：
表三数据：
2传统方法：
使用ALT+D+P功能的多重合并计算，但是在添加字段时，如果存在100张表格，那么这种方法的效率是极低的
3VBA代码
那么只需要使用VBA方法，就能轻松快速的解决，如果你的字段不是3个，那么仅需将下面字段中的标红位置进行相应修改即可！
VBA代码
Sub 多表合并()
Dim arr()
For Each sh In Sheets
If <> '汇总' Then
arr1 = sh.Range('a2:c' & edRange.Rows.Count)
act = act + UBound(arr1)
ReDim Preserve arr(1 To 3, 1 To act) '
For j = 1 To UBound(arr1)
n = n + 1
arr(1, n) = arr1(j, 1)
arr(2, n) = arr1(j, 2)
arr(3, n) = arr1(j, 3)
Next
End If
Next
Sheets('汇总').[a2].Resize(n, 3) = Application.Transpose(arr)
End Sub
将文件另存为xlsm格式，要不然重新打开文件时这段代码就消失了！。

多工作簿多工作表汇总实例集锦

1，多工作表汇总（C o n s o l i d a t e）‘‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。

Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorksheetDim sht As WorksheetDim WbCount As IntegerSet bk = Sheets("汇总")WbCount = Sheets.CountReDim RangeArray(1 To WbCount - 1)For Each sht In SheetsIf <> "汇总" Theni = i + 1RangeArray(i) = "'" & & "'!" & _sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextbk.Range("A1").Consolidate RangeArray, xlSum, True, True[a1].Value = "姓名"End SubSub sumdemo()Dim arr As Variantarr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6")With Worksheets("汇总").Range("A1").Consolidate arr, xlSum, True, True.Value = "姓名"End WithEnd Sub2，多工作簿汇总（Consolidate）‘多工作簿汇总Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorkbookDim sht As WorksheetDim WbCount As IntegerWbCount = Workbooks.CountReDim RangeArray(1 To WbCount - 1)For Each bk In Workbooks '在所有工作簿中循环If Not bk Is ThisWorkbook Then '非代码所在工作簿Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表i = i + 1RangeArray(i) = "'[" & & "]" & & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextWorksheets(1).Range("A1").Consolidate _RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总（FileSearch）‘2007-1-1.html###‘help\汇总表.xlsSub pldrwb0531()'汇总表.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = 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.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$Sub pldrwb0531()'汇总表.xls'导入指定文件的数据（默认工作表1的数据）'直接从C列依次导入Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetss = s & & ","Nexts = Left(s, Len(s) - 1)ar = Split(s, ",")UserForm1.ShowFor j = 0 To UBound(ar1)If Err.Number = 9 Then GoTo 100Set sh = 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).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))‘Cells(3, col1).Resize(UBound(arr), 1) = arrNext j100: wb.Close savechanges:=FalseSet wb = Nothings = ""If VarType(ar1) = 8200 Then Erase ar1End IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To ListBox1.ListCount - 1If ListBox1.Selected(i) = True Thens = s & ListBox1.List(i) & ","End IfNext iIf s <> "" Thens = Left(s, Len(s) - 1)ar1 = Split(s, ",")MsgBox "你选择了" & sUnload UserForm1Elsemg = MsgBox("你没有选择任何工作表！需要重新选择吗？", vbYesNo, "提示") If mg = 6 ThenElseUnload UserForm1End IfEnd IfEnd SubPrivate Sub CommandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBox1.List = ar ‘文本框赋值.ListStyle = 1 ‘文本前加选择小方框.MultiSelect = 1 ‘设置可多选End WithEnd Sub4，多工作表汇总（字典、数组）‘‘Data多表汇总0623.xlsSub dbhz()'多表汇总Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As WorksheetDim d, k, t, Myr&, Arr, xApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet d = CreateObject("Scripting.Dictionary")For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字If InStr(, "-") > 0 Then Sht.Delete: GoTo 100nm = Mid(Sht.[a3], 7)d(nm) = ""100:Next ShtApplication.DisplayAlerts = Truek = d.keysFor i = 0 To UBound(k)Sheets.Add after:=Sheets(Sheets.Count)Set Sht1 = ActiveSheet = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In SheetsWith Sht.ActivateIf InStr(.Name, "-") = 0 Thennm = Replace(Mid(.[a3], 7), "/", "-")Myr = .[h65536].End(xlUp).RowArr = .Range("d10:h" & Myr)Set d = CreateObject("Scripting.Dictionary")For i = 1 To UBound(Arr)x = Arr(i, 1)If Not d.exists(x) Thend.Add x, Arr(i, 5)Elsed(x) = d(x) + Arr(i, 5)End IfNextk = d.keyst = d.itemsSet Sht2 = Sheets(nm)Sht2.Activatemyr2 = [a65536].End(xlUp).Row + 1If myr2 < 9 ThenCells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")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) End IfErase kErase tSet d = NothingEnd IfEnd WithNext ShtApplication.ScreenUpdating = TrueEnd Sub5，多工作簿提取指定数据（FileSearch）‘2011-8-31‘9188-1-1.htmlSub GetData()Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)Dim myFs As FileSearch, myfileDim myPath As String, Filename$, wbnm$Dim i&, n&, mm&, aa$, nm1$, j&Dim Sht1 As Worksheet, sh As Worksheet, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb1 = ThisWorkbookwbnm = Left(, Len() - 4)Set Sht1 = ActiveSheetSht1.[a2:w200] = ""aa = Left(, 2)Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\"With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0)If nm1 = wbnm Then GoTo 200Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsIf InStr(, aa) Thensh.ActivateIf aa = "班子" Thenmm = mm + 1Brrbz(mm, 1) = [b2].ValueFor j = 2 To 18 Step 2If j < 10 ThenBrrbz(mm, j) = Cells(j / 2 + 34, 11).ValueElseBrrbz(mm, j) = Cells(j / 2 + 34, 9).ValueEnd IfNextGoTo 100ElseIf [b2] = "" Then GoTo 50mm = mm + 1Brrgr(mm, 1) = [b2].ValueBrrgr(mm, 2) = [e38].ValueBrrgr(mm, 3) = [i38].ValueFor j = 4 To 18 Step 2If j < 12 ThenBrrgr(mm, j) = Cells(j / 2 + 38, 8).ValueElseBrrgr(mm, j) = Cells(j / 2 + 38, 7).ValueEnd IfNextFor j = 20 To 23Brrgr(mm, j) = Cells(j + 28, 8).ValueNextEnd IfEnd If50:Next100:wb.Close savechanges:=FalseSet wb = Nothing200:NextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithIf aa = "班子" Then[a2].Resize(mm, 19) = BrrbzElse[a2].Resize(mm, 23) = BrrgrEnd If[a1].SelectSet myFs = NothingEnd Sub‘2011-7-15‘Sub pldrsj()'批量导入指定文件的数据? ? Dim myFs As FileSearch, myfile, Brr? ? Dim myPath$, Filename$, nm2$? ? Dim i&, j&, n&, aa$, nm$? ? Dim Sht1 As Worksheet, sh As Worksheet? ? Application.ScreenUpdating = False? ? Set Sht1 = ActiveSheet? ? nm2 = ? ? Set myFs = Application.FileSearch? ? myPath = ThisWorkbook.Path? ? With myFs? ?? ???.NewSearch? ?? ???.LookIn = myPath? ?? ???.FileType = msoFileTypeNoteItem? ?? ???.Filename = "*.xls"? ?? ???.SearchSubFolders = True? ?? ???If .Execute(SortBy:=msoSortByFileName) > 0 Then? ?? ?? ?? ?n = .FoundFiles.Count? ?? ?? ?? ?ReDim Brr(1 To n, 1 To 2)? ?? ?? ?? ?ReDim myfile(1 To n) As String? ?? ?? ?? ?For i = 1 To n? ?? ?? ?? ?? ? myfile(i) = .FoundFiles(i)? ?? ?? ?? ?? ? Filename = myfile(i)? ?? ?? ?? ?? ? aa = InStrRev(Filename, "\")? ?? ?? ?? ?? ? nm = Right(Filename, Len(Filename) - aa)? ?? ?'带后缀的Excel文件名? ?? ?? ?? ?? ? If nm <> nm2 Then? ?? ?? ?? ?? ?? ???j = j + 1? ?? ?? ?? ?? ?? ???Workbooks.Open myfile(i)? ?? ?? ?? ?? ?? ???Dim wb As Workbook? ?? ?? ?? ?? ?? ???Set wb = ActiveWorkbook? ?? ?? ?? ?? ?? ???Set sh = wb.Sheets("Sheet1")? ?? ?? ?? ?? ?? ???Brr(j, 1) = nm? ?? ?? ?? ?? ?? ???Brr(j, 2) = sh.[c3].Value? ?? ?? ?? ?? ?? ???wb.Close savechanges:=False? ?? ?? ?? ?? ?? ???Set wb = Nothing? ?? ?? ?? ?? ? End If? ?? ?? ?? ?Next? ?? ???Else? ?? ?? ?? ?MsgBox "该文件夹里没有任何文件"? ?? ???End If? ? End With? ? Sht1.Select? ? [a3].Resize(UBound(Brr), 2) = Brr? ? Set myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()6387-1-1.html'Report 2.xls'批量导入指定文件的数据Dim myFs As FileSearch, myfileDim myPath As String, Filename$, ma&, mc&Dim i As Long, n As Long, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheet: nn = 5Sht1.[b5:e27] = ""Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\data" ‘指定的子文件夹内搜索With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(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文件名If nm1 <> ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetssh.Activatema = [b65536].End(xlUp).RowIf ma > 6 Then ‘第6行是表头If ma > 10 Then ma = 10 ‘只要取4行数据For ii = 7 To maSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 6).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End Ifmc = [d65536].End(xlUp).RowIf mc > 7 Then ‘第7行是表头If mc > 11 Then mc = 11 ‘只要取4行数据For ii = 8 To mcSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 8).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End If100:Next shwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘‘sum.xlsSub pldrsj0724()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, Myr1&, ArrDim myPath$, Filename$, nm2$Dim i&, j&, n&, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetMyr1 = Sht1.[a65536].End(xlUp).RowArr = Sht1.Range("a3:b" & Myr1)Sht1.Range("b3:b" & Myr1).ClearContentsnm2 = Left(, Len() - 4)Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> nm2 ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsFor j = 1 To UBound(Arr)If = Arr(j, 1) Thensh.ActivateSet r1 = Range("c:c").Find()nn = r1.RowArr(j, 2) = Cells(nn, 9)GoTo 100End IfNext jNext sh100:wb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2)Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub6，多工作表提取指定数据（数组）‘Sub fpkf()Application.ScreenUpdating = FalseDim Myr&, Arr, yf, x&, Myr1&, r1Dim Sht As WorksheetMyr = Sheet1.[b65536].End(xlUp).RowSheet1.Range("c8:h" & Myr).ClearContentsArr = Sheet1.Range("c8:h" & Myr)[j8].Formula = "=rc[-9]&""|""&rc[-8]"[j8].AutoFill Range("j8:j" & Myr)Range("j8:j" & Myr) = Range("j8:j" & Myr).ValueFor Each Sht In SheetsIf <> Thenyf = Left(, Len() - 2)Sht.ActivateMyr1 = [a65536].End(xlUp).Row - 1For x = 7 To Myr1If Cells(x, 1) <> "" ThenSet r1 = Sheet1.Range("j:j").Find(Cells(x, 1) & "|" & Cells(x, 2))If Not r1 Is Nothing ThenArr(r1.Row - 7, yf) = Cells(x, "ar")End IfEnd IfNext xEnd IfNextSheet1.Activate[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr[j:j].ClearApplication.ScreenUpdating = TrueEnd Sub7，多工作簿多工作表查询汇总去重复值（字典数组）‘‘详细记录.xls‘3个工作簿需要都打开Sub xxjl()Dim Sht1 As Worksheet, Sht As WorksheetDim wb1 As Workbook, wb2 As Workbook, wb3 As WorkbookDim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$Application.ScreenUpdating = FalseSet wb1 = ActiveWorkbookSet wb2 = Workbooks("购进")Set wb3 = Workbooks("配料")wb2.ActivateMyr2 = [a65536].End(xlUp).RowArr2 = Range("a2:d" & Myr2)wb3.ActivateFor i = 1 To UBound(Arr2)? ? wb3.Activate? ? xm = Arr2(i, 2)? ? For Each Sht In Sheets? ?? ???If = xm Then? ?? ?? ?? ?Sht.Activate? ?? ?? ?? ?Myr = [a65536].End(xlUp).Row? ?? ?? ?? ?Arr = Range("a1:b" & Myr)? ?? ?? ?? ?For j = 1 To UBound(Arr)? ?? ?? ?? ?? ? yl = Arr(j, 1)? ?? ?? ?? ?? ? wb1.Activate? ?? ?? ?? ?? ? For Each Sht1 In Sheets? ?? ?? ?? ?? ?? ???If = yl Then? ?? ?? ?? ?? ?? ?? ?? ?Sht1.Activate? ?? ?? ?? ?? ?? ?? ?? ?Myr1 = [a65536].End(xlUp).Row + 1? ?? ?? ?? ?? ?? ?? ?? ?Cells(Myr1, 1) = Arr2(i, 1)? ?? ?? ?? ?? ?? ?? ?? ?Cells(Myr1, 3) = Arr2(i, 3)? ?? ?? ?? ?? ?? ?? ?? ?Cells(Myr1, 2) = Arr2(i, 4) * Arr(j, 2) ? ?? ?? ?? ?? ?? ?? ?? ?Exit For? ?? ?? ?? ?? ?? ???End If? ?? ?? ?? ?? ? Next? ?? ?? ?? ?Next j? ?? ?? ?? ?GoTo 100? ?? ???End If? ? Next100:Next iCall qccfApplication.ScreenUpdating = TrueEnd SubSub qccf()Dim Sht As Worksheet, Myr&, Arr, i&, xDim d, k, t, Arr1, j&Application.ScreenUpdating = FalseFor Each Sht In Sheets? ? Sht.Activate? ? Myr = [a65536].End(xlUp).Row? ? Arr = Range("a2:c" & Myr)? ? Set d = CreateObject("Scripting.Dictionary")? ? If Myr < 3 Then GoTo 100? ? For i = 1 To UBound(Arr)? ?? ???x = Arr(i, 1) & "," & Arr(i, 3)? ?? ???If Not d.exists(x) Then? ?? ?? ?? ?d(x) = Arr(i, 2)? ?? ???Else? ?? ?? ?? ?d(x) = d(x) + Arr(i, 2)? ?? ???End If? ? Next? ? k = d.keys? ? t = d.items? ? ReDim Arr1(1 To UBound(k) + 1, 1 To 3)? ? For j = 0 To UBound(k)? ?? ???Arr1(j + 1, 1) = Split(k(j), ",")(0)? ?? ???Arr1(j + 1, 3) = Split(k(j), ",")(1)? ?? ???Arr1(j + 1, 2) = t(j)? ? Next j? ? Range("a2:c" & Myr).ClearContents? ? [a2].Resize(UBound(Arr1), 3) = Arr1100:? ? Set d = NothingNextApplication.ScreenUpdating = TrueEnd Sub8，多工作簿对比（FileSearch）‘599&pid=3285214&page=1&extra=page%3D1Sub dgzbdb()'多工作簿对比'by:蓝桥 2009-11-7Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, nm$, myfileDim Sht1 As Worksheet, sh As WorksheetDim wb1 As Workbook, yf, j&, m1&Dim m, arr, r1Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume NextSet wb1 = ThisWorkbookSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathFor Each Sht1 In Sheets? ? If InStr(Sht1.[a1], "费用明细表") > 0 Then? ?? ???nm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5)? ?? ???Sht1.Activate? ?? ???With myFs? ?? ?? ?? ?.NewSearch? ?? ?? ?? ?.LookIn = myPath? ?? ?? ?? ?.FileType = msoFileTypeNoteItem? ?? ?? ?? ?.Filename = nm & ".xls"? ?? ?? ?? ?.SearchSubFolders = True? ?? ?? ?? ?If .Execute(SortBy:=msoSortByFileName) > 0 Then ? ?? ?? ?? ?? ? myfile = .FoundFiles(1)? ?? ?? ?? ?? ? Workbooks.Open myfile? ?? ?? ?? ?? ? Dim wb As Workbook? ?? ?? ?? ?? ? Set wb = ActiveWorkbook? ?? ?? ?? ?? ? Set sh = wb.ActiveSheet? ?? ?? ?? ?? ? m = sh.[a65536].End(xlUp).Row? ?? ?? ?? ?? ? arr = sh.Range(Cells(2, 1), Cells(m, 6))? ?? ?? ?? ?? ? yf = Val(Split(arr(2, 1), ".")(1))? ?? ?? ?? ?? ? Sht1.Activate? ?? ?? ?? ?? ? For j = 1 To UBound(arr)? ?? ?? ?? ?? ?? ???Set r1 = Sht1.Range("c:c").Find(arr(j, 3))? ?? ?? ?? ?? ?? ???If r1 Is Nothing Then? ?? ?? ?? ?? ?? ?? ?? ?m1 = Sht1.[d65536].End(xlUp).Row? ?? ?? ?? ?? ?? ?? ?? ?Cells(m1, 1).EntireRow.Insert shift:=xlUp ? ?? ?? ?? ?? ?? ?? ?? ?Cells(m1, 1) = Cells(m1 - 1, 1) + 1? ?? ?? ?? ?? ?? ?? ?? ?Cells(m1, 2) = arr(j, 3)? ?? ?? ?? ?? ?? ?? ?? ?Cells(m1, yf + 3) = arr(j, 6)? ?? ?? ?? ?? ?? ???End If? ?? ?? ?? ?? ? Next j? ?? ?? ?? ?? ? wb.Close savechanges:=False? ?? ?? ?? ?? ? Set wb = Nothing? ?? ?? ?? ?End If? ?? ???End With? ? End IfNextSet myFs = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub9，多工作簿汇总（FileSearch+字典）‘Sub pldrwb1123()'合并.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, y&, bb, j&, xDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, Arr, r1, mm&Dim d, k, t, d1, t1Application.ScreenUpdating = Falsemm = 8Set Sht1 = ActiveSheetSht1.[a8:h1000].ClearContentsSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "合并" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).RowArr = Range(Cells(8, 1), Cells(m, 7))Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")For j = 1 To UBound(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.ActivateFor y = 0 To UBound(k)bb = Split(k(y), "|")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.Close savechanges:=FalseSet wb = NothingSet d = NothingSet d1 = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub10，多工作簿多工作表提取数据（Do While）‘3D1‘年度汇总.xlsSub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&Application.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "年度汇总.xls"myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Arr = .Sheets("领料").Range("A1").CurrentRegionFor Each sh In wb.Sheetsshnm = sh.ActivateIf InStr(shnm, "班") > 0 Thencol = 11Elsecol = 7End IfFor i = 2 To UBound(Arr)If Arr(i, col) = shnm Thenm = sh.[a65536].End(xlUp).Row + 1Cells(m, 1).Resize(1, 12) = Application.Index(Arr, i, 0)End IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘Sub tqsj()Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$ Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheet[a2:g1000].ClearContentsfunm = "提取数据.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Activatepm = sh.[a4].ValueMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("b9:e" & Myr)m = m + 1With Sht1.Cells(m, 1) = myName.Cells(m, 2) = pm.Cells(m, 3) = shnm.Cells(m, 4).Resize(UBound(Arr), 4) = ArrEnd Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘‘我想要的结果.xlsSub zdgx()Dim Arr, myPath$, myName$, sh As WorksheetDim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = "我想要的结果.xls"Set Sht = ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle = xlNonemyPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")n = 2Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set sh = .Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowArr = sh.Range("a2:f" & m)Cells(n, 1).Resize(m - 1, 6) = Arrn = n + m - 1.Close FalseEnd WithmyName = DirLoopSht.Range("a2:f" & n - 1).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub‘‘汇总工作表.xls 2010-2-7Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = 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) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = 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) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘9493-1-1.htmlSub ndhz() ‘设置工作表在此处要用Sheets("汇总")格式Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, n%, i&, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "汇总.xls": n = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")wb.Sheets("汇总").[a2:e100].ClearDo While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb1 = Workbooks(myName)Set sh = wb1.Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowWith wb.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)) End With.Close FalseEnd WithmyName = DirLoopwb.Sheets("汇总").Range("a2:e" & n).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub0459-1-1.html‘ABC.xls 2010-5-28Sub dgzbsj()Dim Arr, i&, sh$, n&, myPath$, shnm$, nm$, ad$Dim Sht As Worksheet, m&, Arr1, r1On Error Resume NextApplication.ScreenUpdating = FalsemyPath = ThisWorkbook.Path & "\"。

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

1，多工作表汇总（Consolidate）‘/dispbbs.asp?boardID=5&ID=110630&page=1‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。

Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorksheetDim sht As WorksheetDim WbCount As IntegerSet bk = Sheets("汇总")WbCount = Sheets.CountReDim RangeArray(1 To WbCount - 1)For Each sht In SheetsIf <> "汇总" Theni = i + 1RangeArray(i) = "'" & & "'!" & _sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextbk.Range("A1").Consolidate RangeArray, xlSum, True, True[a1].Value = "姓名"End SubSub sumdemo()Dim arr As Variantarr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6") With Worksheets("汇总").Range("A1").Consolidate arr, xlSum, True, True.Value = "姓名"End WithEnd Sub2，多工作簿汇总（Consolidate）‘多工作簿汇总Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorkbookDim sht As WorksheetDim WbCount As IntegerWbCount = Workbooks.CountReDim RangeArray(1 To WbCount - 1)For Each bk In Workbooks '在所有工作簿中循环If Not bk Is ThisWorkbook Then '非代码所在工作簿Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表i = i + 1RangeArray(i) = "'[" & & "]" & & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextWorksheets(1).Range("A1").Consolidate _RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总（FileSearch）‘/thread-442007-1-1.html###‘help\汇总表.xlsSub pldrwb0531()'汇总表.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = 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.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$Sub pldrwb0531()'汇总表.xls'导入指定文件的数据（默认工作表1的数据）'直接从C列依次导入Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetss = s & & ","Nexts = Left(s, Len(s) - 1)ar = Split(s, ",")UserForm1.ShowFor j = 0 To UBound(ar1)If Err.Number = 9 Then GoTo 100Set sh = 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).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))‘Cells(3, col1).Resize(UBound(arr), 1) = arrNext j100: wb.Close savechanges:=FalseSet wb = Nothings = ""If VarType(ar1) = 8200 Then Erase ar1End IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To ListBox1.ListCount - 1If ListBox1.Selected(i) = True Thens = s & ListBox1.List(i) & ","End IfNext iIf s <> "" Thens = Left(s, Len(s) - 1)ar1 = Split(s, ",")MsgBox "你选择了" & sUnload UserForm1Elsemg = MsgBox("你没有选择任何工作表！需要重新选择吗？", vbYesNo, "提示") If mg = 6 ThenElseUnload UserForm1End IfEnd IfEnd SubPrivate Sub CommandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBox1.List = ar ‘文本框赋值.ListStyle = 1 ‘文本前加选择小方框.MultiSelect = 1 ‘设置可多选End Withbel1.Caption = bel1.Caption & nmEnd Sub4，多工作表汇总（字典、数组）‘/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D 1‘Data多表汇总0623.xlsSub dbhz()'多表汇总Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As WorksheetDim d, k, t, Myr&, Arr, xApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet d = CreateObject("Scripting.Dictionary")For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字If InStr(, "-") > 0 Then Sht.Delete: GoTo 100nm = Mid(Sht.[a3], 7)d(nm) = ""100:Next ShtApplication.DisplayAlerts = Truek = d.keysFor i = 0 To UBound(k)Sheets.Add after:=Sheets(Sheets.Count)Set Sht1 = ActiveSheet = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In SheetsWith Sht.ActivateIf InStr(.Name, "-") = 0 Thennm = Replace(Mid(.[a3], 7), "/", "-")Myr = .[h65536].End(xlUp).RowArr = .Range("d10:h" & Myr)Set d = CreateObject("Scripting.Dictionary")For i = 1 To UBound(Arr)x = Arr(i, 1)If Not d.exists(x) Thend.Add x, Arr(i, 5)Elsed(x) = d(x) + Arr(i, 5)End IfNextk = d.keyst = d.itemsSet Sht2 = Sheets(nm)Sht2.Activatemyr2 = [a65536].End(xlUp).Row + 1If myr2 < 9 ThenCells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")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) End IfErase kErase tSet d = NothingEnd IfEnd WithNext ShtApplication.ScreenUpdating = TrueEnd Sub5，多工作簿提取指定数据（FileSearch）‘2011-8-31‘/thread-759188-1-1.htmlSub GetData()Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)Dim myFs As FileSearch, myfileDim myPath As String, Filename$, wbnm$Dim i&, n&, mm&, aa$, nm1$, j&Dim Sht1 As Worksheet, sh As Worksheet, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb1 = ThisWorkbookwbnm = Left(, Len() - 4)Set Sht1 = ActiveSheetSht1.[a2:w200] = ""aa = Left(, 2)Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\"With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0)If nm1 = wbnm Then GoTo 200Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsIf InStr(, aa) Thensh.ActivateIf aa = "班子" Thenmm = mm + 1Brrbz(mm, 1) = [b2].ValueFor j = 2 To 18 Step 2If j < 10 ThenBrrbz(mm, j) = Cells(j / 2 + 34, 11).ValueElseBrrbz(mm, j) = Cells(j / 2 + 34, 9).ValueEnd IfNextGoTo 100ElseIf [b2] = "" Then GoTo 50mm = mm + 1Brrgr(mm, 1) = [b2].ValueBrrgr(mm, 2) = [e38].ValueBrrgr(mm, 3) = [i38].ValueFor j = 4 To 18 Step 2If j < 12 ThenBrrgr(mm, j) = Cells(j / 2 + 38, 8).ValueElseBrrgr(mm, j) = Cells(j / 2 + 38, 7).ValueEnd IfNextFor j = 20 To 23Brrgr(mm, j) = Cells(j + 28, 8).ValueNextEnd IfEnd If50:Next100:wb.Close savechanges:=FalseSet wb = Nothing200:NextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithIf aa = "班子" Then[a2].Resize(mm, 19) = BrrbzElse[a2].Resize(mm, 23) = BrrgrEnd If[a1].SelectSet myFs = NothingEnd Sub‘2011-7-15‘/viewthread.php?tid=741341&pid=5036524&page=1&extra= Sub pldrsj()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, BrrDim myPath$, Filename$, nm2$Dim i&, j&, n&, aa$, nm$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetSht1.Cells.ClearContentsnm2 = Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim Brr(1 To n, 1 To 2)ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名If nm <> nm2 Thenj = j + 1Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.Sheets("Sheet1")Brr(j, 1) = nmBrr(j, 2) = sh.[c3].Valuewb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[a3].Resize(UBound(Brr), 2) = BrrSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()'/thread-456387-1-1.html'Report 2.xls'批量导入指定文件的数据Dim myFs As FileSearch, myfileDim myPath As String, Filename$, ma&, mc&Dim i As Long, n As Long, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheet: nn = 5Sht1.[b5:e27] = ""Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\data" ‘指定的子文件夹内搜索With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(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文件名If nm1 <> ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetssh.Activatema = [b65536].End(xlUp).RowIf ma > 6 Then ‘第6行是表头If ma > 10 Then ma = 10 ‘只要取4行数据For ii = 7 To maSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 6).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End Ifmc = [d65536].End(xlUp).RowIf mc > 7 Then ‘第7行是表头If mc > 11 Then mc = 11 ‘只要取4行数据For ii = 8 To mcSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 8).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End If100:Next shwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D 2‘sum.xlsSub pldrsj0724()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, Myr1&, ArrDim myPath$, Filename$, nm2$Dim i&, j&, n&, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetMyr1 = Sht1.[a65536].End(xlUp).RowArr = Sht1.Range("a3:b" & Myr1)Sht1.Range("b3:b" & Myr1).ClearContentsnm2 = Left(, Len() - 4)Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> nm2 ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsFor j = 1 To UBound(Arr)If = Arr(j, 1) Thensh.ActivateSet r1 = Range("c:c").Find()nn = r1.RowArr(j, 2) = Cells(nn, 9)GoTo 100End IfNext jNext sh100:wb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2)Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub6，多工作表提取指定数据（数组）‘/viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718 Sub fpkf()Application.ScreenUpdating = FalseDim Myr&, Arr, yf, x&, Myr1&, r1Dim Sht As WorksheetMyr = Sheet1.[b65536].End(xlUp).RowSheet1.Range("c8:h" & Myr).ClearContentsArr = Sheet1.Range("c8:h" & Myr)[j8].Formula = "=rc[-9]&""|""&rc[-8]"[j8].AutoFill Range("j8:j" & Myr)Range("j8:j" & Myr) = Range("j8:j" & Myr).ValueFor Each Sht In SheetsIf <> Thenyf = Left(, Len() - 2)Sht.ActivateMyr1 = [a65536].End(xlUp).Row - 1For x = 7 To Myr1If Cells(x, 1) <> "" ThenSet r1 = Sheet1.Range("j:j").Find(Cells(x, 1) & "|" & Cells(x, 2))If Not r1 Is Nothing ThenArr(r1.Row - 7, yf) = Cells(x, "ar")End IfEnd IfNext xEnd IfNextSheet1.Activate[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr[j:j].ClearApplication.ScreenUpdating = TrueEnd Sub7，多工作簿多工作表查询汇总去重复值（字典数组）‘/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D 1‘详细记录.xls‘3个工作簿需要都打开Sub xxjl()Dim Sht1 As Worksheet, Sht As WorksheetDim wb1 As Workbook, wb2 As Workbook, wb3 As WorkbookDim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$Application.ScreenUpdating = FalseSet wb1 = ActiveWorkbookSet wb2 = Workbooks("购进")Set wb3 = Workbooks("配料")wb2.ActivateMyr2 = [a65536].End(xlUp).RowArr2 = Range("a2:d" & Myr2)wb3.ActivateFor i = 1 To UBound(Arr2)wb3.Activatexm = Arr2(i, 2)For Each Sht In SheetsIf = xm ThenSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a1:b" & Myr)For j = 1 To UBound(Arr)yl = Arr(j, 1)wb1.ActivateFor Each Sht1 In SheetsIf = yl ThenSht1.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)Exit ForEnd IfNextNext jGoTo 100End IfNext100:Next iCall qccfApplication.ScreenUpdating = TrueEnd SubSub qccf()Dim Sht As Worksheet, Myr&, Arr, i&, xDim d, k, t, Arr1, j&Application.ScreenUpdating = FalseFor Each Sht In SheetsSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a2:c" & Myr)Set d = CreateObject("Scripting.Dictionary")If Myr < 3 Then GoTo 100For i = 1 To UBound(Arr)x = Arr(i, 1) & "," & Arr(i, 3)If Not d.exists(x) Thend(x) = Arr(i, 2)Elsed(x) = d(x) + Arr(i, 2)End IfNextk = d.keyst = d.itemsReDim Arr1(1 To UBound(k) + 1, 1 To 3)For j = 0 To UBound(k)Arr1(j + 1, 1) = Split(k(j), ",")(0)Arr1(j + 1, 3) = Split(k(j), ",")(1)Arr1(j + 1, 2) = t(j)Next jRange("a2:c" & Myr).ClearContents[a2].Resize(UBound(Arr1), 3) = Arr1100:Set d = NothingNextApplication.ScreenUpdating = TrueEnd Sub8，多工作簿对比（FileSearch）‘/viewthread.php?tid=499599&pid=3285214&page=1&extra=page%3D1Sub dgzbdb()'多工作簿对比'by:蓝桥 2009-11-7Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, nm$, myfileDim Sht1 As Worksheet, sh As WorksheetDim wb1 As Workbook, yf, j&, m1&Dim m, arr, r1Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume NextSet wb1 = ThisWorkbookSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathFor Each Sht1 In SheetsIf InStr(Sht1.[a1], "费用明细表") > 0 Thennm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5)Sht1.ActivateWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = nm & ".xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenmyfile = .FoundFiles(1)Workbooks.Open myfileDim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.ActiveSheetm = sh.[a65536].End(xlUp).Rowarr = sh.Range(Cells(2, 1), Cells(m, 6))yf = Val(Split(arr(2, 1), ".")(1))Sht1.ActivateFor j = 1 To UBound(arr)Set r1 = Sht1.Range("c:c").Find(arr(j, 3))If r1 Is Nothing Thenm1 = Sht1.[d65536].End(xlUp).RowCells(m1, 1).EntireRow.Insert shift:=xlUp Cells(m1, 1) = Cells(m1 - 1, 1) + 1Cells(m1, 2) = arr(j, 3)Cells(m1, yf + 3) = arr(j, 6)End IfNext jwb.Close savechanges:=FalseSet wb = NothingEnd IfEnd WithEnd IfNextSet myFs = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub9，多工作簿汇总（FileSearch+字典）‘/viewthread.php?tid=504957&pid=3323070& page=1&extra=page%3D1Sub pldrwb1123()'合并.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, y&, bb, j&, xDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, Arr, r1, mm&Dim d, k, t, d1, t1Application.ScreenUpdating = Falsemm = 8Set Sht1 = ActiveSheetSht1.[a8:h1000].ClearContentsSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "合并" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).RowArr = Range(Cells(8, 1), Cells(m, 7))Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")For j = 1 To UBound(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.ActivateFor y = 0 To UBound(k)bb = Split(k(y), "|")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.Close savechanges:=FalseSet wb = NothingSet d = NothingSet d1 = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub10，多工作簿多工作表提取数据（Do While）‘/viewthread.php?tid=511250&pid=3368549&page=1&extra=page%3D 1‘年度汇总.xlsSub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&Application.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "年度汇总.xls"myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Arr = .Sheets("领料").Range("A1").CurrentRegionFor Each sh In wb.Sheetsshnm = sh.ActivateIf InStr(shnm, "班") > 0 Thencol = 11Elsecol = 7End IfFor i = 2 To UBound(Arr)If Arr(i, col) = shnm Thenm = sh.[a65536].End(xlUp).Row + 1Cells(m, 1).Resize(1, 12) = Application.Index(Arr, i, 0)End IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&page=1#pid4261137Sub tqsj()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheet[a2:g1000].ClearContentsfunm = "提取数据.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Activatepm = sh.[a4].ValueMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("b9:e" & Myr)m = m + 1With Sht1.Cells(m, 1) = myName.Cells(m, 2) = pm.Cells(m, 3) = shnm.Cells(m, 4).Resize(UBound(Arr), 4) = ArrEnd Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=521786&pid=3439524&page=1&extra=page%3D 1‘我想要的结果.xlsSub zdgx()Dim Arr, myPath$, myName$, sh As WorksheetDim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = "我想要的结果.xls"Set Sht = ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle = xlNonemyPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")n = 2Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set sh = .Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowArr = sh.Range("a2:f" & m)Cells(n, 1).Resize(m - 1, 6) = Arrn = n + m - 1.Close FalseEnd WithmyName = DirLoopSht.Range("a2:f" & n - 1).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub‘/dispbbs.asp?boardid=5&id=113181&star=1#1455753‘汇总工作表.xls 2010-2-7Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = 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) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&pid=4261137&page=1&extra=page%3D 1Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = 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) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/thread-539493-1-1.htmlSub ndhz() ‘设置工作表在此处要用Sheets("汇总")格式Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, n%, i&, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "汇总.xls": n = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")wb.Sheets("汇总").[a2:e100].ClearDo While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb1 = Workbooks(myName)Set sh = wb1.Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowWith wb.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)) End With.Close FalseEnd WithmyName = DirLoopwb.Sheets("汇总").Range("a2:e" & n).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub'/thread-580459-1-1.html‘ABC.xls 2010-5-28Sub dgzbsj()Dim Arr, i&, sh$, n&, myPath$, shnm$, nm$, ad$Dim Sht As Worksheet, m&, Arr1, r1On Error Resume NextApplication.ScreenUpdating = False。

利用VBA快速整理合并Excel工作薄中多个工作表

利用VBA快速整理合并Excel工作薄中多个工作表
如果一个工作薄中存在若干工作表，且工作表的格式一样的话，如果想快速将这些工作表整合到一个工作表中，则可以使用VBA代码。

省略低级的复制粘贴操作，并提高效率。

（常识：工作薄包含工作表）
实例：
1、一个Excel中存在三个表格(实际中存在多个效果方法一样)
2、进入Excel VBA编辑器（alt+F11）
3、插入一个模块，并将代码复制到模块中
4、F5运行，即可将3个工作表的内容合并到同一个表中。

省去复制、粘贴的麻烦。

代码：
Sub hz()
Set NewSheet = Sheets.Add(Type:=xlWorksheet) '生成一个新表
Sheets(NewSheet.Index).Move before:=Sheets(1) '将此表移动到最前面
For i = 2 To Worksheets.Count
Sheets(i).UsedRange.Copy NewSheet.Cells([a65536].End(xlUp).Row + 2, 1) '将其他表中的已用区域复制到新表中
Next i
MsgBox "合并完成"
End Sub。

运用VBA实现大量Excel工作薄和工作表快速合并成一张工作表

运用VBA实现大量Excel工作薄快速合并成一张工作表在实际工作中，运用VBA能快速实现上述需求，避免大量重复的复制粘贴，提高了工作效率，保证了数据采集的质量。

方法1：一、将大量工作薄合并成一个工作薄1、新建一个工作薄，将其命名为你合并后的名字。

2、打开工作薄，留下一张工作表将多余的删除，在工作表标签上单击右键，选择“查看代码”。

3、在打开的VBA编辑窗口中粘贴以下代码：Sub 工作薄间工作表合并()Dim FileOpenDim X As IntegerApplication.ScreenUpdating = FalseFileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls",MultiSelect:=True, Title:="合并工作薄")X = 1While X <= UBound(FileOpen)1/ 6Workbooks.Open Filename:=FileOpen(X)Sheets().MoveAfter:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)X = X + 1WendExitHandler: Application.ScreenUpdating = TrueExit Suberrhadler:MsgBox Err.DescriptionEnd Sub4、关闭VBA编辑窗口。

5、在Excel 2010中，选择视图—宏—查看宏（如Excel 2003中，选择工具—宏），然后点击“执行”。

6、在打开的对话窗口中，选择所有要合并的工作薄，然后点击“打开”。

二、将大量工作表合并成一张工作表1、在第一张空白工作表标签点击右键，选择“查看代码”。

2/ 62、在打开的VBA编辑窗口中粘贴以下代码：Sub 合并当前工作簿下的所有工作表()Application.ScreenUpdating = FalseFor j = 1 To Sheets.CountIf Sheets(j).Name <> ThenX = Range("A65536").End(xlUp).Row + 1Sheets(j).UsedRange.Copy Cells(X, 1)End IfNextRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"End Sub3、选择运行—运行子过程/用户窗体。

对多个Excel工作簿进行批量操作VBA实例教程

对多个Excel工作簿进行批量操作VBA实例教程之前讲过怎样利用OPEN方法从多个Excel中获得数据，今天我们再来看一个类似的例子，这次我们不是从Excel中取数据，而是要对Excel进行一系列的操作，例如我们要对文件夹中的所有Excel的Sheet1的A1输入“战战如疯”，将Sheet2表格删除。

之前我们讲过打开工作簿可以用OPEN或GetObject，而遍历用的是Dir方法，今天我们就用Open方法结合Dir遍历来讲下怎么解决批量操作的问题。

看下面的代码Sub test()Dim mypath, myfilemypath = ThisWorkbook.Path & '\'myfile = Dir(mypath & '*.xlsx')Application.ScreenUpdating =False '关闭屏幕更新Application.DisplayAlerts =False '关闭提示框Do While myfile <> ''If myfile <> ThenWorkbooks.Open mypath & myfileWith ActiveWorkbook.Sheets(1).Range('A1') = '战战如疯' '这两行就是你要对该工作簿进行的操作，换成自己的代码即可使用.Sheets(2).DeleteEnd WithActiveWorkbook.SaveActiveWorkbook.CloseEnd Ifmyfile = DirLoopApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub上面的代码利用Dir对当前文件夹下所有xlsx后缀的文件进行遍历，遍历的解释参见“利用Dir遍历某文件夹下的所有文件”然后利用Open方法打开工作簿，剩下的就是对其进行操作。

VBA一键汇总多个工作簿

VBA一键汇总多个工作簿VBA一键汇总多个工作簿-名称相同的工作表-的指定区域数据日常工作，我们经常需要汇总相同格式的工作簿的某个工作表的数据如1月业绩、2月业绩。

12月业绩等VBA汇总后变成这样：啥也不说了，直接拿代码去用1.Dim 所有工作簿列表 As FileDialogSelectedItems2.Private Sub 提取数据按钮_Click(sender As Object, e As EventArgs) Handles 提取数据按钮.Click3.4.5.Dim dic As Object = CreateObject("scripting.dictionary")6.Dim wb As Excel.Workbook7.Dim sht As Excel.Worksheet8.Dim j As Long9.10.WithApp.FileDialog(Microsoft.Office.Core.MsoFileDialogType.msoFile DialogFilePicker)11..AllowMultiSelect = True12..Title = "可选择多个工作簿"13.14.If .Show() = -1 Then15.所有工作簿列表 = .SelectedItems '记录所有工作簿，防止二次选择工作簿16.For Each 工作簿路径 As String In .SelectedItems17.18.wb = App.Workbooks.Open(工作簿路径)19.For Each sht In wb.Worksheets20.dic() = ""21.Next22.23.wb.Close(False)24.Next25.26.'将所有表名加载27.For Each 表名 In dic.keysboBox2.Items.Add(表名) '适合汇总同工作表名称的汇总30.31.End If32.End With33.End Sub34.35.Private Sub 汇总数据按钮_Click(sender As Object, e As EventArgs) Handles 汇总数据按钮.Click36.Dim wb As Excel.Workbook37.Dim sht As Excel.Worksheet38.Dim j As Long39.40.41.Dim 开始输出单元格As Excel.Range = App.InputBox("请选择开始输出单元格", Type:=8)42.Dim 输出表 As Excel.Worksheet = App.ActiveSheet43.44.For Each 工作簿路径 As String In 所有工作簿列表45.46.wb = App.Workbooks.Open(工作簿路径)47.For Each sht In wb.Worksheets48.If = ComboBox2.Text Then49.Dim lastrow As Long = 输出表.Cells(输出表.Rows.Count, 开始输出单元格.Column).end(Microsoft.Office.Interop.Excel.XlDirection.xlUp).r ow + 1 '最后一行50.sht.Range(ComboBox3.Text).Copy(输出表.Cells(lastrow, 开始输出单元格.Column)) '尽量不要整列，否则可能出错51.End If53.54.wb.Close(False)55.Next56.End Sub57.58.Private Sub 选择单元格按钮_Click(sender As Object,e As EventArgs) Handles 选择单元格按钮.ClickboBox3.Text = App.InputBox("请选择汇总区域", Type:=8).address60.End Sub我的窗体界面是这样的希望大家多多支持！谢谢。

vba对不同工作表按部门进行汇总填列的方法

VBA对不同工作表按部门进行汇总填列的方法一、前言VBA（Visual Basic for Applications）是一种用于自动化任务和处理数据的编程语言，它广泛应用于Microsoft Excel 中。

在处理大量数据时，人工逐一填写、汇总数据既繁琐又容易出错。

利用VBA编写程序来自动化处理数据成为很多人的选择。

本文将介绍如何利用VBA对不同工作表按部门进行汇总填列的方法。

二、准备工作在进行VBA编程之前，必须要先准备好相关的工作簿和工作表。

1. 打开Excel,创建一个新的工作簿。

在其中创建三张工作表，分别取名为“Sheet1”、“Sheet2” 和“Summary”。

2. 在“Sheet1”中，创建一个数据表，例如包含员工尊称、部门、销售金额等信息。

3. 在“Sheet2”中，创建一个数据表，样式大致与“Sheet1”的数据表相同。

三、利用VBA进行按部门汇总下面介绍如何利用VBA编写程序，将“Sheet1”和“Sheet2”的数据按部门进行汇总填列到“Summary”工作表中。

1. 打开Visual Basic 编辑器（按Alt + F11）。

2. 在“Summary”工作表中创建一个新的模块（右键点击“Summary”工作表，选择“插入”，然后选择“模块”）。

3. 在模块中输入以下代码：```Sub DepartmentSummary()Dim ws1 As WorksheetDim ws2 As WorksheetDim ws3 As WorksheetDim LastRow1 As LongDim LastRow2 As LongDim i As LongDim j As Long'定义三个工作表的对象Set ws1 = ThisWorkbook.Sheets("Sheet1")Set ws2 = ThisWorkbook.Sheets("Sheet2")Set ws3 = ThisWorkbook.Sheets("Summary")'确定数据表的最后一行LastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row LastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row'在Summary工作表中填写表头ws3.Range("A1").Value = "部门"ws3.Range("B1").Value = "销售总额"'按部门对Sheet1和Sheet2进行汇总填列For i = 2 To LastRow1For j = 2 To LastRow2If ws1.Cells(i, 2).Value = ws2.Cells(j, 2).Value Thenws3.Cells(ws3.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = ws1.Cells(i, 2).Valuews3.Cells(ws3.Rows.Count, "B").End(xlUp).Offset(1, 0).Formula = "=SUMIF(Sheet1!$B$2:$B$" LastRow1",Summary!A" ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row ",Sheet1!$C$2:$C$" LastRow1 ")"End IfNext jNext i'显示消息框提示处理完成MsgBox "数据汇总完毧"End Sub```四、代码解析上述代码的主要作用是对“Sheet1”和“Sheet2”的数据按部门进行汇总填写到“Summary”工作表中。

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

1，多工作表汇总（Consolidate）‘/dispbbs.asp?boardID=5&ID=110630&page=1‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。

Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorksheetDim sht As WorksheetDim WbCount As IntegerSet bk = Sheets("汇总")WbCount = Sheets.CountReDim RangeArray(1 To WbCount - 1)For Each sht In SheetsIf <> "汇总" Theni = i + 1RangeArray(i) = "'" & & "'!" & _sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextbk.Range("A1").Consolidate RangeArray, xlSum, True, True[a1].Value = "姓名"End SubSub sumdemo()Dim arr As Variantarr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6") With Worksheets("汇总").Range("A1").Consolidate arr, xlSum, True, True.Value = "姓名"End WithEnd Sub2，多工作簿汇总（Consolidate）‘多工作簿汇总Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorkbookDim sht As WorksheetDim WbCount As IntegerWbCount = Workbooks.CountReDim RangeArray(1 To WbCount - 1)For Each bk In Workbooks '在所有工作簿中循环If Not bk Is ThisWorkbook Then '非代码所在工作簿Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表i = i + 1RangeArray(i) = "'[" & & "]" & & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextWorksheets(1).Range("A1").Consolidate _RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总（FileSearch）‘/thread-442007-1-1.html###‘help\汇总表.xlsSub pldrwb0531()'汇总表.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = 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.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$Sub pldrwb0531()'汇总表.xls'导入指定文件的数据（默认工作表1的数据）'直接从C列依次导入Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetss = s & & ","Nexts = Left(s, Len(s) - 1)ar = Split(s, ",")UserForm1.ShowFor j = 0 To UBound(ar1)If Err.Number = 9 Then GoTo 100Set sh = 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).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))‘Cells(3, col1).Resize(UBound(arr), 1) = arrNext j100: wb.Close savechanges:=FalseSet wb = Nothings = ""If VarType(ar1) = 8200 Then Erase ar1End IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To ListBox1.ListCount - 1If ListBox1.Selected(i) = True Thens = s & ListBox1.List(i) & ","End IfNext iIf s <> "" Thens = Left(s, Len(s) - 1)ar1 = Split(s, ",")MsgBox "你选择了" & sUnload UserForm1Elsemg = MsgBox("你没有选择任何工作表！需要重新选择吗？", vbYesNo, "提示") If mg = 6 ThenElseUnload UserForm1End IfEnd IfEnd SubPrivate Sub CommandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBox1.List = ar ‘文本框赋值.ListStyle = 1 ‘文本前加选择小方框.MultiSelect = 1 ‘设置可多选End Withbel1.Caption = bel1.Caption & nmEnd Sub4，多工作表汇总（字典、数组）‘/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D 1‘Data多表汇总0623.xlsSub dbhz()'多表汇总Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As WorksheetDim d, k, t, Myr&, Arr, xApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet d = CreateObject("Scripting.Dictionary")For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字If InStr(, "-") > 0 Then Sht.Delete: GoTo 100nm = Mid(Sht.[a3], 7)d(nm) = ""100:Next ShtApplication.DisplayAlerts = Truek = d.keysFor i = 0 To UBound(k)Sheets.Add after:=Sheets(Sheets.Count)Set Sht1 = ActiveSheet = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In SheetsWith Sht.ActivateIf InStr(.Name, "-") = 0 Thennm = Replace(Mid(.[a3], 7), "/", "-")Myr = .[h65536].End(xlUp).RowArr = .Range("d10:h" & Myr)Set d = CreateObject("Scripting.Dictionary")For i = 1 To UBound(Arr)x = Arr(i, 1)If Not d.exists(x) Thend.Add x, Arr(i, 5)Elsed(x) = d(x) + Arr(i, 5)End IfNextk = d.keyst = d.itemsSet Sht2 = Sheets(nm)Sht2.Activatemyr2 = [a65536].End(xlUp).Row + 1If myr2 < 9 ThenCells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")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) End IfErase kErase tSet d = NothingEnd IfEnd WithNext ShtApplication.ScreenUpdating = TrueEnd Sub5，多工作簿提取指定数据（FileSearch）‘2011-8-31‘/thread-759188-1-1.htmlSub GetData()Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)Dim myFs As FileSearch, myfileDim myPath As String, Filename$, wbnm$Dim i&, n&, mm&, aa$, nm1$, j&Dim Sht1 As Worksheet, sh As Worksheet, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb1 = ThisWorkbookwbnm = Left(, Len() - 4)Set Sht1 = ActiveSheetSht1.[a2:w200] = ""aa = Left(, 2)Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\"With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0)If nm1 = wbnm Then GoTo 200Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsIf InStr(, aa) Thensh.ActivateIf aa = "班子" Thenmm = mm + 1Brrbz(mm, 1) = [b2].ValueFor j = 2 To 18 Step 2If j < 10 ThenBrrbz(mm, j) = Cells(j / 2 + 34, 11).ValueElseBrrbz(mm, j) = Cells(j / 2 + 34, 9).ValueEnd IfNextGoTo 100ElseIf [b2] = "" Then GoTo 50mm = mm + 1Brrgr(mm, 1) = [b2].ValueBrrgr(mm, 2) = [e38].ValueBrrgr(mm, 3) = [i38].ValueFor j = 4 To 18 Step 2If j < 12 ThenBrrgr(mm, j) = Cells(j / 2 + 38, 8).ValueElseBrrgr(mm, j) = Cells(j / 2 + 38, 7).ValueEnd IfNextFor j = 20 To 23Brrgr(mm, j) = Cells(j + 28, 8).ValueNextEnd IfEnd If50:Next100:wb.Close savechanges:=FalseSet wb = Nothing200:NextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithIf aa = "班子" Then[a2].Resize(mm, 19) = BrrbzElse[a2].Resize(mm, 23) = BrrgrEnd If[a1].SelectSet myFs = NothingEnd Sub‘2011-7-15‘/viewthread.php?tid=741341&pid=5036524&page=1&extra= Sub pldrsj()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, BrrDim myPath$, Filename$, nm2$Dim i&, j&, n&, aa$, nm$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetSht1.Cells.ClearContentsnm2 = Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim Brr(1 To n, 1 To 2)ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名If nm <> nm2 Thenj = j + 1Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.Sheets("Sheet1")Brr(j, 1) = nmBrr(j, 2) = sh.[c3].Valuewb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[a3].Resize(UBound(Brr), 2) = BrrSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()'/thread-456387-1-1.html'Report 2.xls'批量导入指定文件的数据Dim myFs As FileSearch, myfileDim myPath As String, Filename$, ma&, mc&Dim i As Long, n As Long, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheet: nn = 5Sht1.[b5:e27] = ""Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\data" ‘指定的子文件夹内搜索With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(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文件名If nm1 <> ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetssh.Activatema = [b65536].End(xlUp).RowIf ma > 6 Then ‘第6行是表头If ma > 10 Then ma = 10 ‘只要取4行数据For ii = 7 To maSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 6).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End Ifmc = [d65536].End(xlUp).RowIf mc > 7 Then ‘第7行是表头If mc > 11 Then mc = 11 ‘只要取4行数据For ii = 8 To mcSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 8).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End If100:Next shwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D 2‘sum.xlsSub pldrsj0724()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, Myr1&, ArrDim myPath$, Filename$, nm2$Dim i&, j&, n&, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetMyr1 = Sht1.[a65536].End(xlUp).RowArr = Sht1.Range("a3:b" & Myr1)Sht1.Range("b3:b" & Myr1).ClearContentsnm2 = Left(, Len() - 4)Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> nm2 ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsFor j = 1 To UBound(Arr)If = Arr(j, 1) Thensh.ActivateSet r1 = Range("c:c").Find()nn = r1.RowArr(j, 2) = Cells(nn, 9)GoTo 100End IfNext jNext sh100:wb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2)Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub6，多工作表提取指定数据（数组）‘/viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718 Sub fpkf()Application.ScreenUpdating = FalseDim Myr&, Arr, yf, x&, Myr1&, r1Dim Sht As WorksheetMyr = Sheet1.[b65536].End(xlUp).RowSheet1.Range("c8:h" & Myr).ClearContentsArr = Sheet1.Range("c8:h" & Myr)[j8].Formula = "=rc[-9]&""|""&rc[-8]"[j8].AutoFill Range("j8:j" & Myr)Range("j8:j" & Myr) = Range("j8:j" & Myr).ValueFor Each Sht In SheetsIf <> Thenyf = Left(, Len() - 2)Sht.ActivateMyr1 = [a65536].End(xlUp).Row - 1For x = 7 To Myr1If Cells(x, 1) <> "" ThenSet r1 = Sheet1.Range("j:j").Find(Cells(x, 1) & "|" & Cells(x, 2))If Not r1 Is Nothing ThenArr(r1.Row - 7, yf) = Cells(x, "ar")End IfEnd IfNext xEnd IfNextSheet1.Activate[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr[j:j].ClearApplication.ScreenUpdating = TrueEnd Sub7，多工作簿多工作表查询汇总去重复值（字典数组）‘/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D 1‘详细记录.xls‘3个工作簿需要都打开Sub xxjl()Dim Sht1 As Worksheet, Sht As WorksheetDim wb1 As Workbook, wb2 As Workbook, wb3 As WorkbookDim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$Application.ScreenUpdating = FalseSet wb1 = ActiveWorkbookSet wb2 = Workbooks("购进")Set wb3 = Workbooks("配料")wb2.ActivateMyr2 = [a65536].End(xlUp).RowArr2 = Range("a2:d" & Myr2)wb3.ActivateFor i = 1 To UBound(Arr2)wb3.Activatexm = Arr2(i, 2)For Each Sht In SheetsIf = xm ThenSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a1:b" & Myr)For j = 1 To UBound(Arr)yl = Arr(j, 1)wb1.ActivateFor Each Sht1 In SheetsIf = yl ThenSht1.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)Exit ForEnd IfNextNext jGoTo 100End IfNext100:Next iCall qccfApplication.ScreenUpdating = TrueEnd SubSub qccf()Dim Sht As Worksheet, Myr&, Arr, i&, xDim d, k, t, Arr1, j&Application.ScreenUpdating = FalseFor Each Sht In SheetsSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a2:c" & Myr)Set d = CreateObject("Scripting.Dictionary")If Myr < 3 Then GoTo 100For i = 1 To UBound(Arr)x = Arr(i, 1) & "," & Arr(i, 3)If Not d.exists(x) Thend(x) = Arr(i, 2)Elsed(x) = d(x) + Arr(i, 2)End IfNextk = d.keyst = d.itemsReDim Arr1(1 To UBound(k) + 1, 1 To 3)For j = 0 To UBound(k)Arr1(j + 1, 1) = Split(k(j), ",")(0)Arr1(j + 1, 3) = Split(k(j), ",")(1)Arr1(j + 1, 2) = t(j)Next jRange("a2:c" & Myr).ClearContents[a2].Resize(UBound(Arr1), 3) = Arr1100:Set d = NothingNextApplication.ScreenUpdating = TrueEnd Sub8，多工作簿对比（FileSearch）‘/viewthread.php?tid=499599&pid=3285214&page=1&extra=page%3D1Sub dgzbdb()'多工作簿对比'by:蓝桥 2009-11-7Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, nm$, myfileDim Sht1 As Worksheet, sh As WorksheetDim wb1 As Workbook, yf, j&, m1&Dim m, arr, r1Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume NextSet wb1 = ThisWorkbookSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathFor Each Sht1 In SheetsIf InStr(Sht1.[a1], "费用明细表") > 0 Thennm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5)Sht1.ActivateWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = nm & ".xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenmyfile = .FoundFiles(1)Workbooks.Open myfileDim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.ActiveSheetm = sh.[a65536].End(xlUp).Rowarr = sh.Range(Cells(2, 1), Cells(m, 6))yf = Val(Split(arr(2, 1), ".")(1))Sht1.ActivateFor j = 1 To UBound(arr)Set r1 = Sht1.Range("c:c").Find(arr(j, 3))If r1 Is Nothing Thenm1 = Sht1.[d65536].End(xlUp).RowCells(m1, 1).EntireRow.Insert shift:=xlUp Cells(m1, 1) = Cells(m1 - 1, 1) + 1Cells(m1, 2) = arr(j, 3)Cells(m1, yf + 3) = arr(j, 6)End IfNext jwb.Close savechanges:=FalseSet wb = NothingEnd IfEnd WithEnd IfNextSet myFs = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub9，多工作簿汇总（FileSearch+字典）‘/viewthread.php?tid=504957&pid=3323070& page=1&extra=page%3D1Sub pldrwb1123()'合并.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, y&, bb, j&, xDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, Arr, r1, mm&Dim d, k, t, d1, t1Application.ScreenUpdating = Falsemm = 8Set Sht1 = ActiveSheetSht1.[a8:h1000].ClearContentsSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "合并" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).RowArr = Range(Cells(8, 1), Cells(m, 7))Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")For j = 1 To UBound(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.ActivateFor y = 0 To UBound(k)bb = Split(k(y), "|")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.Close savechanges:=FalseSet wb = NothingSet d = NothingSet d1 = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub10，多工作簿多工作表提取数据（Do While）‘/viewthread.php?tid=511250&pid=3368549&page=1&extra=page%3D 1‘年度汇总.xlsSub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&Application.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "年度汇总.xls"myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Arr = .Sheets("领料").Range("A1").CurrentRegionFor Each sh In wb.Sheetsshnm = sh.ActivateIf InStr(shnm, "班") > 0 Thencol = 11Elsecol = 7End IfFor i = 2 To UBound(Arr)If Arr(i, col) = shnm Thenm = sh.[a65536].End(xlUp).Row + 1Cells(m, 1).Resize(1, 12) = Application.Index(Arr, i, 0)End IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&page=1#pid4261137Sub tqsj()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheet[a2:g1000].ClearContentsfunm = "提取数据.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Activatepm = sh.[a4].ValueMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("b9:e" & Myr)m = m + 1With Sht1.Cells(m, 1) = myName.Cells(m, 2) = pm.Cells(m, 3) = shnm.Cells(m, 4).Resize(UBound(Arr), 4) = ArrEnd Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=521786&pid=3439524&page=1&extra=page%3D 1‘我想要的结果.xlsSub zdgx()Dim Arr, myPath$, myName$, sh As WorksheetDim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = "我想要的结果.xls"Set Sht = ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle = xlNonemyPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")n = 2Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set sh = .Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowArr = sh.Range("a2:f" & m)Cells(n, 1).Resize(m - 1, 6) = Arrn = n + m - 1.Close FalseEnd WithmyName = DirLoopSht.Range("a2:f" & n - 1).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub‘/dispbbs.asp?boardid=5&id=113181&star=1#1455753‘汇总工作表.xls 2010-2-7Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = 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) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&pid=4261137&page=1&extra=page%3D 1Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = 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) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/thread-539493-1-1.htmlSub ndhz() ‘设置工作表在此处要用Sheets("汇总")格式Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, n%, i&, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "汇总.xls": n = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")wb.Sheets("汇总").[a2:e100].ClearDo While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb1 = Workbooks(myName)Set sh = wb1.Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowWith wb.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)) End With.Close FalseEnd WithmyName = DirLoopwb.Sheets("汇总").Range("a2:e" & n).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub'/thread-580459-1-1.html‘ABC.xls 2010-5-28Sub dgzbsj()Dim Arr, i&, sh$, n&, myPath$, shnm$, nm$, ad$Dim Sht As Worksheet, m&, Arr1, r1On Error Resume NextApplication.ScreenUpdating = False。

使用VBA合并多个Excel工作簿(3种形式)

使用VBA合并多个Excel工作簿例如，需要将多个Excel工作簿中的工作表合并到一个工作簿。

这里假设需要合并的工作簿在“D:\示例\数据记录\”文件夹中，含有两个工作簿test1.xls、test2.xls（当然，可以不限于两个），在test1.xls工作簿中含有三张工作表，在test2.xls工作簿中含有两张工作表，现在使用一段VBA代码合并这两个工作簿到一个新工作簿中，合并到新工作簿中的工作表分别以原工作簿名加索引值命名。

代码如下：Sub CombineWorkbooks()Dim strFileName As StringDim wb As WorkbookDim ws As Object'包含工作簿的文件夹,可根据实际修改Const strFileDir As String = "D:\示例\数据记录\"Application.ScreenUpdating = FalseSet wb = Workbooks.Add(xlWorksheet)strFileName = Dir(strFileDir & "*.xls*")Do While strFileName <> vbNullStringDim wbOrig As WorkbookSet wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)For Each ws In wbOrig.Sheetsws.Copy After:=wb.Sheets(wb.Sheets.Count)If wbOrig.Sheets.Count > 1 Thenwb.Sheets(wb.Sheets.Count).Name = strFileName & ws.IndexElsewb.Sheets(wb.Sheets.Count).Name = strFileNameEnd IfNextwbOrig.Close SaveChanges:=FalsestrFileName = DirLoopApplication.DisplayAlerts = Falsewb.Sheets(1).DeleteApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueSet wb = NothingEnd Sub2.下面是合并多个Excel工作簿的另一种情形，也是《Excel VBA实战技巧精粹》中<技巧91：汇总多个工作簿的工作表>所介绍的方法，即合并汇总。

多个工作表合并汇总之VBA方法

iBlLczujDft V“aal B^ir 临養市搭十五局人人札吉选举陡昭登记丘工睡输脸皿彳匸十四■j 3 li- ] ij. .—J 債粗泄igiliin 匪出讥沁§£tu ■■氓 Thi iff^Ua^k二1.珂1百¥尸*|£屯61臨。

P«lxtBi tplihYTiL (^LtTaL P A 1K »3ELtbl4Autrflll«@41“ 3Mbl4£dcil<-i.i Tratlaihl^OuCl Ln.1 ux Filxa Ho.ihliiSi-1 ■< L i an D - -rHEE-iT-Lra K MI « —TF取 ud^rdfL 肌h B. »Visibl 虫 -1 - i-lSbM4tvJm EK®J 3、在左上角的"工程”中，选中" ThisWorkbook ”，双击打开，如图;多个工作表合并汇总（VBA 方法）傻瓜教程1打开要汇总工作表的 excel 文件；2、按Alt+F11，打开 VBA 编辑器，如图；IKEiJ ） IV ，心桔式辺用宦型运行⑧ XAQ ）外IftlS 与® 时口妁括助QDQ Sbailfl 雹I SLtti? X专Eictl 中W ・ ILL111J 110.53H i^riaxcift4、复制以下代码在空白处：Sub合并()Dim m As In tegerDim n As In tegerDim o As In tegerFor m = 2 To 30 '此处的30需要根据你实际的工作表数填写n = Sheets(m).[a65536].E nd(xlUp).Rowo = Sheets(1).[a65536].E nd(xlUp).RowSheets(m).SelectRan ge("a1", "z" & n).SelectRan ge("a" & n).ActivateSelectio n.CopySheets(1).SelectRan ge("a" & o + 1).SelectActiveSheet. PasteNextEnd Sub5、全选代码，点击运行图标，如图:6、注意事项：1）汇总好的数据在第一张工作表中；2）“运行”图标每点击一次，就进行一次汇总，切勿点击多次；3）汇总后的数据不能通过“ Ctrl+Z ”来撤销操作，事先须做好数据备份。

1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。

1，多工作表汇总（Consolidate）
‘
‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。