2013.5多表汇总的例子
Excel多表汇总，你会写公式吗？
Excel多表汇总，你会写公式吗？Excel多表汇总，你会写公式吗？工作中经常遇到数据分散在不同的工作表的情况，需要对多张工作表数据进行汇总时，就要用到多表汇总技术了。
多表汇总的方法有很多种，今天来展示一个公式搞定多表汇总的方法。
这种方法最大优势在于当数据源变动时，公式结果可以自动更新，你知道这有多么重要！看完教程还想系统学习的同学，推荐你参加我亲自授课的特训营↓，系统提升自己。
应用场景和数据结构如下图所示，每个月份的数据分别放置在不同的工作表中其中工作表1放置的1月份数据，工作表2放置的2月份数据，依此类推需要在汇总工作表中进行多表汇总，按产品将1月、2月、3月的数据分类汇总统计。
汇总表中的黄色单元格为公式结果。
无论1/2/3月数据如何变动，汇总结果支持自动更新。
公式解法下面先告诉大家这个公式怎么写，再看演示效果。
B2输入以下数组公式，按<Ctrl+Shift+Enter>结束输入，并将公式向下填充=SUM(SUMIF(INDIRECT(ROW($1:$3)&"!b:b"),A2,INDIRECT( ROW($1:$3)&"!c:c")))效果演示为了方便大家清晰、直观地查看效果，我从空表状态填写数据，口算即可验证结果。
点击下图Gif观看动图演示这个公式不但支持数据源变动后结果自动更新，而且当分表中记录增加时，也可以自动更新数据，非常方便。
扩展说明当需要汇总的工作表月份增加时，比如要对1至12月的12张工作表汇总......这时，只需对公式进行简单调整即可=SUM(SUMIF(INDIRECT(ROW($1:$12)&"!b:b"),A2,INDIRECT( ROW($1:$12)&"!c:c")))如果你觉得有用，就分享给朋友们看看吧~。
不同列多表格汇总公式
不同列多表格汇总公式全文共四篇示例，供读者参考第一篇示例：在数据分析和报告中，常常需要将不同表格中的数据进行汇总和整合。
不同列多表格的汇总公式是一种非常有效的方法，可以帮助人们快速准确地统计和分析大量数据。
本文将介绍一些常用的不同列多表格汇总公式，帮助读者更好地理解和运用这些方法。
一、SUMIF函数SUMIF函数是Excel中非常常用的一种计算汇总的方法。
它可以根据指定的条件来汇总数据，在不同列多表格中尤其适用。
SUMIF函数的语法如下：=SUMIF( range, criteria, [sum_range] )range是要进行条件判断的数据范围，criteria是条件判断的标准，sum_range是要汇总的数据范围。
如果我们有两个表格，一个表格中包含员工姓名和销售额数据，另一个表格中包含员工姓名和费用数据，我们可以使用SUMIF函数来计算每个员工的净利润，公式如下：=SUMIF(表格1!A:A, A2, 表格1!B:B) - SUMIF(表格2!A:A, A2, 表格2!B:B)这个公式会先在表格1中找到与当前行员工姓名匹配的销售额，再在表格2中找到与当前行员工姓名匹配的费用，最后求差值得到净利润。
二、VLOOKUP函数VLOOKUP函数是另一种常用的不同列多表格汇总公式。
它可以在不同表格中查找指定的值，并返回相应的结果。
VLOOKUP函数的语法如下：=VLOOKUP( lookup_value, table_array, col_index_num, [range_lookup] )lookup_value是要查找的值，table_array是要查找的范围，col_index_num是返回结果所在列的索引号，range_lookup是一个逻辑值，表示是否使用近似匹配。
如果我们需要在一个表格中根据产品名称查找对应的价格，可以使用VLOOKUP函数，公式如下：=VLOOKUP(A2, 表格1!A:B, 2, FALSE)这个公式会在表格1的第一列中查找与当前行产品名称匹配的值，并返回该值所在列的第二列的数据，即价格。
excel2013多个数据怎么进行汇总
excel2013多个数据怎么进行汇总
推荐文章
Excel2013表格怎么按月年汇总日期数据热度： excel2013怎么对多个数据进行汇总热度：Excel2013怎么汇总数据热度：入党志愿书中的入党志愿怎么写热度：会计人员加薪申请书怎么写热度：在excel2013中输入了多个单元格数据，但是要对这些单元格进行汇总时，应该怎么做?下面随店铺一起来看看吧。
excel2013多个数据进行汇总的步骤
打开我准备好了的数据表格，先单击D列，然后点击菜单栏--数据--分列。
弹出文本分列向导，将文件类型选为分隔符号，单击下一步。
在分隔符号中勾选其他，填入顿号，因为原单元格中是以顿号隔开的，下一步。
填入目标区域，就是分隔之后显示的单元格，完成向导设置。
我们可以看见单元格数据被分隔开来了，在H2单元格输入=Sum(E2：G2)
回车，得到结果，双击填充柄，完成下面数据的计算，然后复制，单击开始选项卡下剪贴板里面的粘贴--粘贴值。
因为这里的结果是根据E：G列来计算的，之后我们要删除这几列，如果不粘贴为值的话，最后结果就无法显示了，出错。
删除中间那几列，将多余的数据去掉，完成最后的效果。
多表汇总再合并
多表汇总再合并1、说明：每月的人员都有变动，且有重名的出现，2、要求：效果是名字别出现遗漏.统计出每月的数据。
3、说明：此表我只选择了三张表，其实有12张表。
4、要求：能不能实现有几张表就统计几张表的？例如，我只有6、7、8三个月，就统计出这三个月的，如果有1、2、3、4、5这几个月的，就统计这五个月的。
此表为汇总的最终结果VBA代码如下：Sub 多表汇总合并()Dim Sht As Worksheet, Arr, BrrDim Dic As Object, x%, i&, k&, y&Set Dic = CreateObject("Scripting.Dictionary")ReDim Brr(1 To Rows.Count, 1 To 14)For Each Sht In SheetsIf <> ThenArr = edRangex = Val(Arr(1, 1)) + 2For i = 4 To UBound(Arr)If Arr(i, 1) <> "" And Arr(i, 2) <> "" ThenIf Not Dic.Exists((Arr(i, 1) & Arr(i, 2))) Thenk = k + 1Dic.Add Arr(i, 1) & Arr(i, 2), kBrr(k, 1) = Arr(i, 1)Brr(k, 2) = Arr(i, 2)Brr(k, x) = Arr(i, 3)Elsey = Dic(Arr(i, 1) & Arr(i, 2))Brr(y, x) = Brr(y, x) + Arr(i, 3)End IfEnd IfNextEnd IfNextedRange.Offset(1).ClearContents Sheet5.Range("A2").Resize(k, 14) = Brr End Sub。
不同表格中满足多个条件汇总数据的函数
标题：如何使用函数在不同表格中满足多个条件汇总数据在日常工作和学习中，我们经常会遇到需要在不同表格中满足多个条件汇总数据的情况。
这时就需要使用函数来实现这一目标。
本文将介绍如何使用函数在不同表格中满足多个条件汇总数据，并共享一些个人观点和理解。
一、函数简介在处理不同表格中满足多个条件汇总数据时，常用的函数包括SUMIF、COUNTIF、AVERAGEIF、SUMIFS、COUNTIFS和AVERAGEIFS。
这些函数能够根据设定的条件，在指定的范围内进行数据的求和、计数和求平均值操作。
二、使用范例假设我们有两个表格，分别记录了不同产品的销售额和销售量。
现在需要统计某个产品的销售额和销售量，同时满足特定条件（比如地区和时间）。
这时就可以使用SUMIFS、COUNTIFS和AVERAGEIFS等函数来实现这一目标。
在Excel中，我们可以按照以下格式使用这些函数：1. 使用SUMIFS函数汇总销售额：=SUMIFS(销售额范围, 产品范围, "产品A", 地区范围, "地区A", 时间范围, "2019年")2. 使用COUNTIFS函数汇总销售量：=COUNTIFS(销售量范围, 产品范围, "产品A", 地区范围, "地区A", 时间范围, "2019年")3. 使用AVERAGEIFS函数汇总平均销售额：=AVERAGEIFS(销售额范围, 产品范围, "产品A", 地区范围, "地区A", 时间范围, "2019年")通过这些函数的灵活运用，我们可以轻松地在不同表格中满足多个条件汇总数据，实现精确的数据分析和统计。
三、个人观点和理解在实际工作中，我发现函数在不同表格中满足多个条件汇总数据是非常实用的。
它不仅能够提高工作效率，还能够准确地分析数据，为决策提供有力支持。
ExcelV精选多工作簿多工作表汇总实例集锦
E x c e l V精选多工作簿多工作表汇总实例集锦 Revised by Liu Jing on January 12, 20211，多工作表汇总（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 Then n = .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) = arr wb.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).AutoFillRange(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 Workbook Application.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, BrrDim myPath$, Filename$, nm2$Dim i&, j&, n&, aa$, nm$Dim Sht1 As Worksheet, sh As Worksheet Application.ScreenUpdating = FalseSet Sht1 = ActiveSheetnm2 = 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()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) Then sh.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 Workbook Dim 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) = Arr1 100:Set d = NothingNextApplication.ScreenUpdating = TrueEnd Sub8，多工作簿对比（FileSearch）‘599&pid=3285214&page=1&extra=page%3D1 Sub dgzbdb()'多工作簿对比'by:蓝桥 2009-11-7Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, nm$, myfileDim Sht1 As Worksheet, sh As Worksheet Dim wb1 As Workbook, yf, j&, m1&Dim m, arr, r1Application.ScreenUpdating = False Application.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 Then myfile = .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+字典）‘Sub pldrwb1123()'合并.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, y&, bb, j&, xDim Sht1 As Worksheet, sh As Worksheet Dim 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 Worksheet Dim 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").CurrentRegion For 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 + 1 Cells(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) = Arr End Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘‘我想要的结果.xlsSub zdgx()Dim Arr, myPath$, myName$, sh As Worksheet Dim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = "我想要的结果.xls"Set Sht = ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle = xlNone myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")n = 2Do While myName <> "" And myName <> funm With 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) = Arr n = 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 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‘9493-1-1.htmlSub ndhz() ‘设置工作表在此处要用Sheets("汇总")格式Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim 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 & "\"sh = Dir(myPath & "*.xls")While Not Len(sh) = 0If sh <> ThenWith GetObject(myPath & sh)Set Sht = .Sheets("Sheet1") ‘要用set以后才能取到数据m = Sht.[b65536].End(xlUp).RowArr = Sht.Range("b3:e" & m)Arr1 = Sht.Range("b4:e" & m)shnm = Left(sh, Len(sh) - 4)For i = 1 To UBound(Arr, 2)nm = Arr(1, i)Sheets(nm).ActivateSet r1 = Cells.Find(shnm, , , 1)If Not r1 Is Nothing Then。
Excel表格中如何快速汇总多个数据表中的数据.doc
Excel表格中如何快速汇总多个数据表中的数据Excel表格中如何快速汇总多个数据表中的数据实用技能酱08.19 14:57阅读171万+在Excel工作表中，如果需要汇总报告多个单独单元格的结果，可以将这些单元格中的数据合并到一个主工作表中。
这些工作表可以与主工作表在同一个工作簿中，也可以分别位于不同的工作簿。
数据的合并计算就是数据的组合过程，下面介绍Excel表格中汇总多个数据表中的数据的具体操作方法。
1、打开需要处理的工作簿，在这个工作簿中，“11月采购表”和“12月采购表”工作表包含需要合并的数据，如图1所示。
“合计”工作表用于放置进行合并计算后的数据，其结构如图2所示。
imgLoadingExcel表格中如何快速汇总多个数据表中的数据图1需要合并的两张工作表imgLoadingExcel表格中如何快速汇总多个数据表中的数据图2“合计”工作表的结构2、在“合计”工作表中单击选择放置合并计算结果的单元格区域中的第一个单元格，然后在功能区“数据”选项卡的“数据工具”组中单击“合并计算”按钮，如图3所示。
imgLoadingExcel表格中如何快速汇总多个数据表中的数据图3单击“合并计3、打开“合并计算”对话框，在“函数”下拉列表框中选择“求和”选项设置合并数据时的计算方式，然后单击“引用位置”文本框右侧的“参照”按钮，如图4所示。
打开“11月采购表”工作表，在工作表中拖动鼠标选择引用单元格后再次单击“参照”按钮，如图5所示。
imgLoadingExcel表格中如何快速汇总多个数据表中的数据图4单击参照按钮imgLoadingExcel表格中如何快速汇总多个数据表中的数据图5选择引用位置4、在“合并计算”对话框中单击“添加”按钮将选择的数据添加到“所有引用位置”列表框中，如图6所示。
imgLoadingExcel表格中如何快速汇总多个数据表中的数据图6添加数据区域到列表框5、单击“合并计算”对话框中“引用位置”文本框右侧的“参照”按钮，采用相同的方法将“12月采购表”工作表中需要合并的数据所在的单元格地址添加到“所有引用位置”列表框中，如图7所示。
利用sum sumif indirect row函数跨表取数实现多表汇总!
利用sum sumif indirect row函数跨表取数实现多表汇总！1、sumif函数对不同月份不同顺序的费用金额进行汇总，如SUMIF('1'！C4:C84'),C5,'1'!e4:e84'))+SUMIF('2'！C4:C84'),C5,'2'!e4:e84'))+...+SUMIF('12'！C4:C84'),C5,'12'!e4:e84'))2、利用INDIRECT函数可以利用数组的特性，简化公式，SUMIF(INDIRECT{1;2;3;4;5;6;7;8;9;10;11;12}&'!C4:C84'，c4,INDIRECT({1;2;3;4;5;6;7;8;9;10;11;12}&'!e4:e84'))3、利用row函数取数组，再次简化函数，SUMIF(INDIRECT(ROW($1:$12)&'!C4:C84'),C4,INDIRECT( ROW($1:$12)&'!e4:e84'))4、利用sum函数作汇总，SUM(SUMIF(INDIRECT(ROW($1:$12)&'!C4:C84'),C4,INDI RECT(ROW($1:$12)&'!e4:e84')))表中也使用了excel 2010下的sumifs函数，参数的顺序不一样，大家可能参考帮助学习使用。
需要说明的是利用indirect时一定注意连接号“&”及英文状态下的双引号“''”，否则会出错。
藤椅3楼snow5112014-4-12 16:04:48 非常感谢，希望笨鸟也能看懂。
板凳4楼snow5112014-4-12 16:11:01 您那个部门是哪来的？报纸5楼漂泊的旅途2014-4-12 16:18:43 引用: snow511 发表于2014-4-12 16:11您那个部门是哪来的？系统数据导出整理的，我们单位分部门考核费用！实际上我们整理数据时，根据需要有调整的。
多工作簿多工作表汇总实例集锦
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 & "\"。
多工作簿多表查询汇总的通用解决方案
多工作簿多表查询汇总的通用解决方案长期以来，论坛内不断出现求多个工作簿、多个工作表进行汇总的求助贴，开始时，抱着能帮多少就多少的心态去尽自己能力去进行帮助，但有时一天内出现几个汇总求助，只是汇总数据的格式不一样，标题字段不一样而已，作为求助者稍微学习一下VBA基础知识，然后照搬照挪代码，就基本可以自己完成的事，却不厌其烦的出现在求助队列里。
本着授之以鱼不如授之以渔的思想，做了一个自己的汇总代码模版，希望能给有汇总需求提供到一定帮助，给初学者一个指引编写代码的学习机会。
代码不一定是非常优秀，希望各位大神级的朋友不要贱笑，也敬请多多指教，多多指正。
前提，所有操作中的表或工作簿中，必须包含所有查询所需的字段标题，但不一定要按同样顺序附件中，每行代码都注释了作用，希望各位初学者学习一些语句的应用。
包含了对工作簿汇总的数组方案、SQL方案；对工作表汇总的数组方案、SQL方案。
数组解决方案中涉及调整规范数据格式的代码Function 规范数据格式(vReadData As Variant, vTitle As Variant) As Variant'将数据规范为一定格式，本例中的格式是：姓名、年龄、籍贯、区域Dim oDic As Object '定义字典对象变量Dim nRow As Double, nCol As Integer, nNewCol As IntegerDim vData As Variant '定义数据规范的数组Set oDic = CreateObject("Scripting.Dictionary") '定义oDic为字典变量'注意：标题的数量要与vReadData数组对应For nRow = LBound(vTitle) To UBound(vTitle) '从数组的最低标号到最高标号循环oDic(vTitle(nRow)) = nRow + 1 '以标题为关键字的字典，赋值对应于标题数组的标号NextvData = vReadData '令vData与vReadData具有同样容量的数组For nCol = 1 To UBound(vReadData, 2) '列号从1到vReadData第二维最高标号，即最右的列号nNewCol = oDic(vReadData(1, nCol)) '从vReadData标题行的标题获取数据规范的所在列For nRow = 2 To UBound(vReadData) '列号从2到vReadData第一维最高标号，即最下的行号vData(nRow, nNewCol) = vReadData(nRow, nCol) '把vReadData赋值到数据规范的数组NextNext规范数据格式 = vData '返回规范数据的数组End Function使用数组访问多个工作簿进行汇总的解决方案Sub 数组查找工作簿汇总()Dim vReadData As Variant '定义读取工作簿中表的数据的数组变量Dim vData As Variant '定义读取工作簿中表的规范格式数据的数组变量Dim wWB As Workbook '定义工作簿变量Dim sPath As String '定义文件夹变量Dim sFile As String '定义文件名变量Dim nRow As Double '定义行数变量Dim nCol As Integer '定义列数变量Dim bAdd As Boolean '定义是否需要作为新记录添加的逻辑变量Dim vFill As Variant '定义将要作为查询结果的数组变量Dim nFill As Double '定义查询结果数组的行数的变量Dim sName As String, sPlace As String, sArea As String, vAge As VariantDim vTitle As Variant '定义标题变量Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度vTitle = Split("姓名|年龄|籍贯|区域", "|") '将所有标题用|隔开的字符串根据|分离成数组sName = Trim([A2]) '获取查询姓名的条件sPlace = Trim([A6]) '获取查询籍贯的条件sArea = Trim([A8]) '获取查询区域的条件vAge = [A4:B4].Value '获取查询年龄的条件ReDimvFill(1 To 4, 1 To 1) '定义一个4列1行的数组'注意：正常填到表格内的数组是按(行，列)来定义的，因为考虑到行数将不断增加，而且数组只能是最后一个维度上进行变化，所以先将行定义在后面Set wWB = ThisWorkbook '设置本工作簿的变量sPath = wWB.Path& "" '获取本工作簿所在文件夹sFile = Dir(sPath& "*.xls*") '查找sPath文件夹内的与xls有关后缀名的文件Do While sFile<> "" '如果查找不到相关文件将会返回空字符串，找到的话，将返回文件名的全名 If sFile<> Then '如果找到的文件名不等于本工作簿的文件名With Workbooks.Open(sPath&sFile) '打开工作簿sFilevReadData = .Sheets(1).UsedRange.Value '将第一个表的所有已用单元格的数值赋值给数组.Close False '关闭工作簿sFileEnd WithvData = 规范数据格式(vReadData, vTitle) '如果所有工作簿内数据格式一致，可以跳过本步，上一步的赋值给vReadData的时候直接赋值给vData即可For nRow = 2 To UBound(vData) 'vData中，第1行是标题，故从2行开始读取数据bAdd = True '初始化变量为真If sName<> "" Then bAdd = bAdd And (vData(nRow, 1) Like "*" &sName& "*")'假如存在姓名条件，且姓名类似条件形式，为真，并跟bAdd进行与运算，例如：条件是”张“，那么”张三“就类似”*张*“If vAge(1, 2) <> "" Then bAdd = bAdd And Application.Evaluate(vData(nRow, 2) &IIf(vAge(1, 1) = "", "=", vAge(1, 1)) &vAge(1, 2))'Evaluate是计算一个字符串形式的式子的值'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号'整个语句就是当条件中有年龄条件数值，对比数据中年龄vData(nRow, 2)是否符合条件If sPlace<> "" Then bAdd = bAdd And (vData(nRow, 1) = sPlace)'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算If sArea<> "" Then bAdd = bAdd And (vData(nRow, 1) = sArea)'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算If bAdd Then '假如条件符合判断逻辑变量bAdd为真时nFill = nFill + 1 '为查询数据数组的行数增加一行ReDim Preserve vFill(1 To 4, 1 To nFill) '为增加一行的查询数据数组重定义For nCol = 1 To 4vFill(nCol, nFill) = vData(nRow, nCol) '复制符合条件的一行数据到查询数据数组最后一行上NextEnd IfNextEnd IfsFile = Dir '查询一个符合条件的文件LoopThisWorkbook.Activate '本工作簿激活为使用状态With Sheets("汇总") '对”汇总“表进行操作.[F:I].ClearContents '清空汇总表内的F:I列数据.[F1:I1] = Split("姓名,年龄,籍贯,区域", ",") '通过以逗号为拆分词来拆分字符串所得数组赋值给F1:I1单元格作为标题If nFill> 0 Then '假如查询数据数组的记录行数大于0，即表示有数据.[F2].Resize(nFill, 4) = Application.WorksheetFunction.Transpose(vFill)'因为前面定义vFill时按（列，行）定义的，需要通过系统的转置函数Transpose转置为（行，列）数组'赋值给由F2开始变形为nFill行，4列的单元格区域End IfEnd With '结束对”汇总“表进行操作Application.ScreenUpdating = TrueEnd Sub使用SQL语句处理多文件汇总的解决方案Sub SQL查找工作簿汇总()Dim oRead_Excel_Conn As Object '定义数据集对象变量Dim sExcel_Select As String '定义EXCEL读取数据SQL语句变量Dim sRead_File_Conn As String '定义读文件的SQL语句连接变量Dim sWhere As String 'SQL语句的条件部分变量Dim wWB As Workbook '定义工作簿变量Dim sPath As String '定义文件夹变量Dim sFile As String '定义文件名变量Dim sName As String, sPlace As String, sArea As String, vAge As VariantDim sTitle As Variant '定义SQL查找的标题变量Dim vTitle As Variant '定义标题变量Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度sTitle = "姓名,年龄,籍贯,区域"sName = Trim([A2]) '获取查询姓名的条件sPlace = Trim([A6]) '获取查询籍贯的条件sArea = Trim([A8]) '获取查询区域的条件vAge = [A4:B4].Value '获取查询年龄的条件sWhere = "Where True" '初始SQL的条件语句If sName<> "" Then sWhere = sWhere& " And [姓名] Like '%" &sName& "%'"'假如存在姓名条件，定义姓名类似条件给sWhereIf vAge(1, 2) <> "" Then sWhere = sWhere& " And [年龄]" &IIf(vAge(1, 1) = "", "=", vAge(1, 1)) &vAge(1, 2)'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号'假如存在年龄条件，定义年龄对应关系条件给sWhereIf sPlace<> "" Then sWhere = sWhere& " And [籍贯]='" &sPlace& "'"'假如存在籍贯条件，定义籍贯相等条件给sWhereIf sArea<> "" Then sWhere = sWhere& " And [区域]='" &sArea& "'"'假如存在区域条件，且区域相等条件给sWhereSet oRead_Excel_Conn = CreateObject("Adodb.Connection") '建立读EXCEL数据SQL数据集If Val(Application.Version) < 12 Then '获取Excel的版本号，低于12为Excel2003版及以下，否则为Excel2007版及以上oRead_Excel_Conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" &ThisWorkbook.FullName '建立数据库连接，Excel2003版及以下ElseoRead_Excel_Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" &ThisWorkbook.FullName '建立数据库连接，Excel2007版及以上End IfSet wWB = ThisWorkbook '设置本工作簿的变量sPath = wWB.Path& "" '获取本工作簿所在文件夹sFile = Dir(sPath& "*.xls*") '查找sPath文件夹内的与xls有关后缀名的文件Do While sFile<> "" '如果查找不到相关文件将会返回空字符串，找到的话，将返回文件名的全名 If sFile<> Then '如果找到的文件名不等于本工作簿的文件名If LCase(Left(sFile, 3)) = "xls" Then '如果文件名右边三个字符(即后缀名)的小写与2003版本文件一样sRead_File_Conn = "[Excel 8.0;Database=" &sPath&sFile& "]."'使用SQL语句打开非由oRead_Excel_Conn所定义的文件以外的文件，使用这种格式打开，注意别漏了后面的点ElsesRead_File_Conn = "[Excel 12.0;Database=" &sPath&sFile& "]."End IfIf sExcel_Select<> "" ThensExcel_Select = sExcel_Select& " Union All " '如果已经存在SQL语句，使用联合语句关联文件的连接End IfsExcel_Select = sExcel_Select& "(Select " &sTitle& " From " &sRead_File_Conn& "[Sheet1$] "&sWhere& ")" '读取文件中Sheet1表End IfsFile = Dir '查询一个符合条件的文件LoopThisWorkbook.Activate '本工作簿激活为使用状态With Sheets("汇总") '对”汇总“表进行操作.[F:I].ClearContents '清空汇总表内的F:I列数据vTitle = Split(sTitle, ",") '将所有标题用,隔开的字符串根据,分离成数组.[F1:I1] = vTitle '通过以逗号为拆分词来拆分字符串所得的数组赋值给F1:I1单元格作为标题.[F2].CopyFromRecordsetoRead_Excel_Conn.Execute(sExcel_Select) '执行SQL语句并赋值到F2为起始的单元格区域End With '结束对”汇总“表进行操作oRead_Excel_Conn.Close '关闭文件SQL连接Set oRead_Excel_Conn = Nothing '清除对象的SQL属性Application.ScreenUpdating = TrueEnd Sub使用数组处理多表汇总的解决方案Sub 数组查找工作表汇总()Dim wSH As Worksheet '定义工作表的变量Dim vReadData As Variant '定义读取工作表的数据的数组变量Dim vData As Variant '定义读取工作表的规范格式数据的数组变量Dim nRow As Double '定义行数变量Dim nCol As Integer '定义列数变量Dim bAdd As Boolean '定义是否需要作为新记录添加的逻辑变量Dim vFill As Variant '定义将要作为查询结果的数组变量Dim nFill As Double '定义查询结果数组的行数的变量Dim sName As String, sPlace As String, sArea As String, vAge As VariantDim vTitle As Variant '定义标题变量Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度vTitle = Split("姓名|年龄|籍贯|区域", "|") '将所有标题用|隔开的字符串根据|分离成数组sName = Trim([A2]) '获取查询姓名的条件sPlace = Trim([A6]) '获取查询籍贯的条件sArea = Trim([A8]) '获取查询区域的条件vAge = [A4:B4].Value '获取查询年龄的条件ReDimvFill(1 To 4, 1 To 1) '定义一个4列1行的数组'注意：正常填到表格内的数组是按(行，列)来定义的，因为考虑到行数将不断增加，而且数组只能是最后一个维度上进行变化，所以先将行定义在后面For Each wSH In Sheets '查找工作簿中的每一个表If <> "汇总" Then '如果找到的工作表的标签名不等于“汇总”vReadData = edRange.Value '将工作表的所有已用单元格的数值赋值给数组vData = 规范数据格式(vReadData, vTitle) '如果所有工作表内数据格式一致，可以跳过本步，上一步的赋值给vReadData的时候直接赋值给vData即可For nRow = 2 To UBound(vData) 'vData中，第1行是标题，故从2行开始读取数据bAdd = True '初始化变量为真If sName<> "" Then bAdd = bAdd And (vData(nRow, 1) Like "*" &sName& "*")'假如存在姓名条件，且姓名类似条件形式，为真，并跟bAdd进行与运算，例如：条件是”张“，那么”张三“就类似”*张*“If vAge(1, 2) <> "" Then bAdd = bAdd And Application.Evaluate(vData(nRow, 2) &IIf(vAge(1, 1) = "", "=", vAge(1, 1)) &vAge(1, 2))'Evaluate是计算一个字符串形式的式子的值'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号'整个语句就是当条件中有年龄条件数值，对比数据中年龄vData(nRow, 2)是否符合条件If sPlace<> "" Then bAdd = bAdd And (vData(nRow, 1) = sPlace)'假如存在籍贯条件，且籍贯与条件相同，为真，并跟bAdd进行与运算If sArea<> "" Then bAdd = bAdd And (vData(nRow, 1) = sArea)'假如存在区域条件，且区域与条件相同，为真，并跟bAdd进行与运算If bAdd Then '假如条件符合判断逻辑变量bAdd为真时nFill = nFill + 1 '为查询数据数组的行数增加一行ReDim Preserve vFill(1 To 4, 1 To nFill) '为增加一行的查询数据数组重定义For nCol = 1 To 4vFill(nCol, nFill) = vData(nRow, nCol) '复制符合条件的一行数据到查询数据数组最后一行上NextEnd IfNextEnd IfNextWith Sheets("汇总") '对”汇总“表进行操作.[F:I].ClearContents '清空汇总表内的F:I列数据.[F1:I1] = Split("姓名,年龄,籍贯,区域", ",") '通过以逗号为拆分词来拆分字符串所得数组赋值给F1:I1单元格作为标题If nFill> 0 Then '假如查询数据数组的记录行数大于0，即表示有数据.[F2].Resize(nFill, 4) = Application.WorksheetFunction.Transpose(vFill)'因为前面定义vFill时按（列，行）定义的，需要通过系统的转置函数Transpose转置为（行，列）数组'赋值给由F2开始变形为nFill行，4列的单元格区域End IfEnd With '结束对”汇总“表进行操作Application.ScreenUpdating = TrueEnd Sub使用SQL处理多表汇总的解决方案Sub SQL查找工作表汇总()Dim wSH As Worksheet '定义工作表的变量Dim oRead_Excel_Conn As Object '定义数据集对象变量Dim sExcel_Select As String '定义EXCEL读取数据SQL语句变量Dim sRead_File_Conn As String '定义读文件的SQL语句连接变量Dim sWhere As String 'SQL语句的条件部分变量Dim sName As String, sPlace As String, sArea As String, vAge As VariantDim sTitle As Variant '定义SQL查找的标题变量Dim vTitle As Variant '定义标题变量Application.ScreenUpdating = False '禁止数据更新，避免因数据更新时引起闪屏，提高运行速度sTitle = "姓名,年龄,籍贯,区域"sName = Trim([A2]) '获取查询姓名的条件sPlace = Trim([A6]) '获取查询籍贯的条件sArea = Trim([A8]) '获取查询区域的条件vAge = [A4:B4].Value '获取查询年龄的条件sWhere = "Where True" '初始SQL的条件语句If sName<> "" Then sWhere = sWhere& " And [姓名] Like '%" &sName& "%'"'假如存在姓名条件，定义姓名类似条件给sWhereIf vAge(1, 2) <> "" Then sWhere = sWhere& " And [年龄]" &IIf(vAge(1, 1) = "", "=", vAge(1, 1)) &vAge(1, 2)'IIf(vAge(1, 1) = "", "=", vAge(1, 1)) ,如果年龄的比较符号vAge(1, 1)没有被选择，默认使用等于号'假如存在年龄条件，定义年龄对应关系条件给sWhereIf sPlace<> "" Then sWhere = sWhere& " And [籍贯]='" &sPlace& "'"'假如存在籍贯条件，定义籍贯相等条件给sWhereIf sArea<> "" Then sWhere = sWhere& " And [区域]='" &sArea& "'"'假如存在区域条件，且区域相等条件给sWhereSet oRead_Excel_Conn = CreateObject("Adodb.Connection") '建立读EXCEL数据SQL数据集If Val(Application.Version) < 12 Then '获取Excel的版本号，低于12为Excel2003版及以下，否则为Excel2007版及以上oRead_Excel_Conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" &ThisWorkbook.FullName '建立数据库连接，Excel2003版及以下ElseoRead_Excel_Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" &ThisWorkbook.FullName '建立数据库连接，Excel2007版及以上End IfFor Each wSH In Sheets '查找工作簿中的每一个表If <> "汇总" Then '如果找到的工作表的标签名不等于“汇总”If sExcel_Select<> "" ThensExcel_Select = sExcel_Select& " Union All " '如果已经存在SQL语句，使用联合语句关联工作表的连接End IfsExcel_Select = sExcel_Select& "(Select " &sTitle& " From [" && "$] " &sWhere& ")" '读取工作表End IfNextWith Sheets("汇总") '对”汇总“表进行操作.[F:I].ClearContents '清空汇总表内的F:I列数据vTitle = Split(sTitle, ",") '将所有标题用,隔开的字符串根据,分离成数组.[F1:I1] = vTitle '通过以逗号为拆分词来拆分字符串所得的数组赋值给F1:I1单元格作为标题.[F2].CopyFromRecordsetoRead_Excel_Conn.Execute(sExcel_Select) '执行SQL语句并赋值到F2为起始的单元格区域End With '结束对”汇总“表进行操作oRead_Excel_Conn.Close '关闭文件SQL连接Set oRead_Excel_Conn = Nothing '清除对象的SQL属性Application.ScreenUpdating = TrueEnd Sub平时养成好习惯很重要1、定义好变量2、属性配对，各种属性关系使用陷入方式，按Tab键内进一下If……End IfFor……NextDo While……LoopWith……End With等之间语句用陷入一些的方式，在查找Bug和维护时很有用。
Excel2013怎么汇总数据
Excel2013怎么汇总数据
在excel2013中，需要对输入的大量数据进行汇总，应该怎么做?下面随店铺一起来看看吧。
Excel2013汇总数据的步骤
启动Excel，打开需要进行处理的表格数据，选中D2：D14区域，按下键盘上的F5键，弹出定位框，单击定位条件按钮。
在定位条件对话框中，勾选空值，确定。
此时会自动选中D2：D14中的空值单元格，单击菜单栏--公式--自动求和。
这样空值中就算出了各大区域的总和，然后在编辑栏，将D5改为汇总，或者其他的名称，自己设定都行。
工作做好了，接下来在单元格输入：=min(汇总)，回车即可得到结果。
最后的效果如下所示，显然华中地区是最小的。
多条件多表求和汇总
多条件多表求和汇总1. 多条件多表求和汇总就像把一群调皮捣蛋的小怪兽从各个神秘山洞（多表）里揪出来，按照奇怪的魔法规则（多条件）加在一起，那过程简直比驯服一群乱窜的独角兽还难。
2. 这多条件多表求和汇总啊，好似要把散落在不同星球（多表）的奇异宝石，根据神秘的星象图（多条件）收集起来计算总和，脑袋都要变成一团乱麻球啦。
3. 多条件多表求和汇总仿佛是把藏在无数个魔法口袋（多表）里的稀奇古怪的魔法道具，依照复杂的魔法咒语（多条件）来统计总量，感觉自己像个迷糊的小巫师。
4. 它就像把从各地森林（多表）里窜出来的精灵，按照古老精灵族的神秘约定（多条件）进行求和，这事儿复杂得像要解开哥德巴赫猜想。
5. 多条件多表求和汇总像是从无数个宝盒（多表）里拿出宝贝，按照苛刻的藏宝图规则（多条件）计算总和，比在迷宫里找出口还让人头疼。
6. 这多条件多表求和汇总啊，好比要把在不同梦境（多表）里的奇异景象，按照荒诞的解梦法则（多条件）加起来，我的脑子都快像烟花一样炸掉了。
7. 多条件多表求和汇总仿佛是把住在不同云朵城堡（多表）的小天使，按照天庭的古怪律法（多条件）汇总数量，难如让猴子写出一篇优美的诗歌。
8. 它就像把在各个深海漩涡（多表）里的神秘生物，根据海神的神秘旨意（多条件）求和，这操作复杂得像要给银河系每个星球都取个新名字。
9. 多条件多表求和汇总像是从各个神秘古堡（多表）里的幽灵，按照幽灵世界的特殊契约（多条件）统计总和，搞得我像迷失在异世界的小可怜。
10. 这多条件多表求和汇总啊，好似把在不同童话王国（多表）的小矮人和巨人，按照童话女王的命令（多条件）加起来，我的思维都快打结打得像麻花了。
11. 多条件多表求和汇总仿佛是把在不同魔法学院（多表）的小魔法师的魔法值，按照大魔法师的古怪要求（多条件）求和，比让乌龟跑得比兔子快还离谱。
12. 它就像把在各个古老部落（多表）的独特图腾，根据部落长老的神秘指示（多条件）计算总和，感觉自己在数字的原始森林里迷了路。
Excel教程：多表汇总原来这么简单
Excel教程：多表汇总原来这么简单双12优惠大放价，限时特价【解锁会员】支持微信公众号+小程序+APP+PC网站多平台学习大家好，我是爱知趣教育小木老师，今天来讲一下多表汇总原来这么简单今天给大家分享的是多表“汇总”,这是一位VIP同学的问题,她每个客户一张表,每一张表里又有31张表用来分别记录每天的数据!表格建好以后,要将所有客户的数据汇总到一个表中,想着有没有公式能直接引用过来,而不用每个单元格都去写一下引用。
拿到她的数据表，打开看，表结构都是完全一样的，取数据的位置也是完全一样，很有规律！图01 第一天取F42单元格的值，从第二天开始，都是间隔44行，第二天取第86行的值，42+44=86，第三天取第130行的值，42+44+44=130，所以取多少行的数据可以用公式（天数-1）*44+42 计算出来。
弄清楚规则以后再来选函数，这个问题可以用index,offset,indirect 来解决！三个函数的套路都一样。
首先来看index的解法图02：这里只用了Index 前两个参数，参数1是返回数据的区域，这里我是整列引用参数2是返回区域中第几行的值，这里用的是(A3-1)*44+42再来看Offset的解法图03：Offset用了3个参数参数1是偏移的基点，用F1做为起始点（注意要绝对引用，否则下拉填充时基点会变）参数2是偏移多少行，用(A3-1)*44+41 （注意这里是加41，而不是加42因为是从A1开始的，加41就对了，不知道为什么会这么巧）用这两个函数都挺容易实现的，可现在有另一个问题，每一列都要重新写一下公式，有好几十个客户呢，能不能只写一次，然后右拉，下拉就能实现的呢？这时候就该轮到indirect上场了，图04：后面计算行号的部分和用index完全一样（注意A3要绝对引用列），前面的工作表名称则直接引用了B2单元格的值！（注意这里要绝对引用行，右拉的时候列必须是可以变化，下拉的时候行则不能变化）工作表名称前后加上单引号是标准用法，如果工作表名称都是字母或汉字，可以这样写INDIRECT(B$2& '!F' & ($A3-1)*44+42)如果合计位置并没有规律呢？关注我：下一次带你用VBA 来秒杀此问题！。
用合并计算轻松汇总多表数据的方法
用合并计算轻松汇总多表数据的方法一提到数据汇总，大部分人首先想到的是函数。
其实，在Excel中，不用函数，合并计算功能就能快速将多表数据汇总或合并到另一个表格中。
特别是当每个表格中的顺序、项目不完全相同时，使用合并计算功能汇总更简单。
合并计算既可以按类别汇总，也可以按位置汇总。
此外，合并计算的数据源区域可以是同一工作表中的不同表格，也可以是同一工作簿中的不同工作表，还可以是不同工作簿中的表格。
今天就给大家分享使用Excel合并计算功能汇总或合并数据的方法。
1．按位置合并计算多工作表数据通过位置来合并计算数据是指在所有源区域中的数据以相同的结构排列，也就是说，需要在每个源区域中合并计算的数值必须在被选定源区域的相对位置上。
这种方式非常适用于处理相同表格的合并工作。
例如，总公司将各分店的销售数据合并到一个工作表中。
下图所示的3个工作表分别为某公司销售一分部、销售二分部和销售三分部的销售数据，可发现这3个工作表中的数据以相同的结构排列。
现要合计3个工作表中的数据，具体操作步骤如下。
第 1 步打开'各销售分部汇总表 .xlsx'文件，切换至'汇总'工作表，选中单元格B2，切换至'数据'选项卡，在'数据工具'组中单击'合并计算'按钮，如下图所示。
第2 步弹出'合并计算'对话框，保持默认的'函数'设置，设置'引用位置'为'销售一分部！$B$2:$F$14'，单击'添加'按钮，如下图所示。
第 3 步使用相同的方法将其他工作表中的相同单元格区域添加到'所有引用位置'列表框中，选中'首行'复选框，单击'确定'按钮，如下图所示。
第 4 步返回工作表中，可看到合并计算多工作表相同单元格区域后的汇总效果，如下图所示。
汇总多个工作簿的数据到总表
.AskToUpdateLinks = False
End With
ReDim aResult(1 To 50000, 1 To 1)
'--------声明结果数组
Cells.ClearContents
.Close False
'--------关闭工作簿
End With
End If
strFileName = Dir
'--------下一个excel文件
Loop
If k > 0 Then
aResult(k, 1) = strFileName
'--------数组第一列放工作簿名称
aResult(k, 2) =
'--------数组第二列放工作表名称
strKey = InputBox("请输入需要合并的工作表所包含的关键词：", "提醒")
If StrPtr(strKey) = 0 Then Exit Sub
'--------如果点击了取消或者关闭按钮，则退出程序
lngTitleRow = Val(InputBox("请输入标题的行数", "提醒", 1))
5、点击【阅读原文】可以下载示例文件。建议下载附件后阅读代码，手机微信阅读代码…………………………………………………………………………………………………………………………………………………………无语。
照例动画操作：
代码如下：
Sub CollectWorkBookDatas()
'ExcelHome VBA编程学习与实践，看见星光
多表汇总，轻松搞定
多表汇总，轻松搞定
小伙伴们好啊，上次星星跟大家分享过利用多重合并计算实现二维表转一维表，大家觉得怎么样呢？
今天我们继续来分享多重合并计算另一个强大的功能。
在工作当中经常会遇到由不同的区域、或不同的销售员提交上来的销售明细报表，而我们要做的就是将这些明细报表进行汇总。
没错，就是多表汇总，一听到多表汇总，那肯定有很多小伙伴无比头疼啊，今天星星要来教大家利用多重合并计算来实现多表汇总。
准备好了吗？
首先我们看这里有4个不同区域的明细报表分别存放在两个工作簿内。
注意：这里我们销售报表的字段名称和维度一定要是一样的，如图：
依次按ALT D P
调出透视表与透视图向导，选择多重合并计算。
单击下一步，在步骤2中选择自定义字段，如下图：
在这里根据需要选择添加的数据源及页字段数目，本例页字段数目选择2。
添加好数据源，并对每个数据源的页字段项目添加字段标签，如下图：
此时点击完成，就自动生成数据透视表了。
也可以将【页2】拖到【列标签】，如下图：
怎么样？多表汇总实现了吧,是不是也特别简单呢？
接下来就是修改字段名称和给数据透视表化化妆啦，能使它好看一些，变得美美哒。
小伙伴学会了吗？简单的多表汇总，就这么快哦。
最后留给大家一个问题，如果有多个行字段，如何进行汇总呢，你会操作吗？
还不赶快行动起来，让数据透视表带你飞咯——
透视表学员：紫星。
Excel多表汇总数据--传统函数篇
Excel多表汇总数据--传统函数篇关注 Excel 全家福置顶公众号主持人：多表求和、多表汇总数据一直以来都是Excel领域里永恒不变的主题，在“错综复杂”的实际工作案例中，Excel精英们更是大显身手、各显神通，创造和挖掘出各式各样的解决办法，为我们职场人员提供了便利。
然而为了应对如今的“大数据”时代，我们的Excel 办公软件增添了新函数、升级了VBA、开发了Power Query等功能，一次又一次的刷新了我们的认知！打开看点快报，查看高清大图解说员：上面第一张图片是集团公司“2019年工资汇总表”，需要按“员工号”汇总2019年1月-12月所有员工的工资总额。
第二张图片是集团公司1月的工资表，2月-12月工资表格式和1月工资表完全相同。
我们通过图片上“总工资”那一列清楚的看到了汇总数据，然而汇总数据的公式却显得尤为尴尬！下面我们请”牛先生“的徒弟“小试牛刀”来进行一番的讲解。
小试牛刀：“='1月'!D2+'2月'!D2+'3月'!D2+'4月'!D2+'5月'!D2+'6月'!D2+'7月'!D2+'8月'!D2+'9月'!D2+'10月'!D2+'11月'!D2+'12月'!D2”公式优点是“简单粗暴”，适合于汇总数据工作表很少的情形下，缺点是当要汇总数据工作表很多时，重复性劳动会增加工作量并且很难保证数字的准确性，造成数据上的损失。
下面我通过传统函数法给大家展示一下Tip1：我们通过第一张图片，观察发现需要汇总的工作表名称是有规律的，阿拉伯数字“1-12”加一个汉字“月”组成。
此时我们可以使用ROW函数或者COLUMN函数生成一组”1-12“的数字组，这些数字组可以通过连接符”&“和”月“组合生成一组”1-12月“的工作表名称组，在这里我们通常使用ROW函数，编辑公式=ROW($1:$12)&'月'打开看点快报，查看高清大图Tip2：我们通过第二张图片，观察发现需要汇总的工作表数据源也是有规律的，都在”D列“，此时我们可以把Tip1中的公式再重新编辑一下让它生成工作表名称组的数据源，编辑公式=ROW($1:$12)&'月!D:D'打开看点快报，查看高清大图Tip3：我们经过上面的操作，需要把生成工作表名称组的数据源引用到汇总表中，此时我们可以使用INDIRECT函数实现这样的过程，INDIRECT函数有直接引用和间接引用两种方式，在这里我们使用间接引用的方式来完成引用效果，编辑公式=INDIRECT(ROW($1:$12)&'月!D:D')打开看点快报，查看高清大图Tip4：因为我们要进行求和，所以需要使用条件求和SUMIF函数。