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对多个工作簿进行合并计算（求和）一例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将多个工作簿的全部工作表合并到一个工作簿中本文转载自公众号：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_多工作簿多工作表汇总实例集锦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工作簿的几个例子将许多个工作簿中的工作表合并到一个工作薄中,然后对数据进行统计计算,举了几种合并的案例。

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（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方法可以保存工作簿。

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 & "\"。

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。