EXCEL多条件汇总实例(VBA)
EXCEL多条件汇总实例
EXCEL多条件汇总实例在Excel中，可以使用VBA编程来实现多条件汇总。
VBA是Excel中的一种宏语言，可以编写自动化操作程序，实现各种复杂的任务，在此例中我们要实现根据多个条件对数据进行汇总。
在模块中，我们需要定义一个Sub过程来执行我们的多条件汇总操作。
以下是一个示例的VBA代码：```Sub MulticonditionSummaryDim wsSource As WorksheetDim wsSummary As WorksheetDim lastRow As LongDim i As Long'设置源数据工作表和汇总工作表Set wsSource = ThisWorkbook.Sheets("源数据")Set wsSummary = ThisWorkbook.Sheets("汇总数据")'清空汇总数据工作表wsSummary.Cells.Clear'获取源数据工作表最后一行lastRow = wsSource.Cells(wsSource.Rows.Count,1).End(xlUp).Row'设置汇总数据表头wsSummary.Range("A1").Value = "条件1"wsSummary.Range("B1").Value = "条件2"wsSummary.Range("C1").Value = "数量"'初始化汇总行数i=2'开始循环源数据For Each cell In wsSource.Range("A2:A" & lastRow)'检查条件If cell.Value = "条件1" And cell.Offset(0, 1).Value = "条件2" Then'将匹配的数据填写到汇总工作表wsSummary.Cells(i, 1).Value = cell.ValuewsSummary.Cells(i, 2).Value = cell.Offset(0, 1).ValuewsSummary.Cells(i, 3).Value = cell.Offset(0, 2).Valuei=i+1End IfNext cell'格式化汇总数据wsSummary.Columns("A:C").AutoFit'提示完成MsgBox "多条件汇总已完成！"End Sub```在上面的示例中，我们首先定义了一些变量，包括源数据工作表(wsSource)，汇总数据工作表(wsSummary)，最后一行的行数(lastRow)和循环中的索引变量(i)。
利用VB编写多条件分类汇总和排序的宏程序
利用 VB 编写多条件分类汇总和排序的宏程序周 宝摘 要： 通过实例介绍使用 Excel 中 的 VB 编 辑 器 ， 编 写 可 使 用多条件的排序和分类汇总的宏 程序。
关键词： 宏程序； 多条件的排序和分类汇总Excel ； VB ； “交检， 合格， 工料废-统计结果 （产品 A ）” 工作表---是 对应上面原始表统计后结果表。
（4） 操作实例的过程使用 fm_5c4d_tj_into_5c4d_qk_sort 宏程序指定相应的 “ 例 子条件文 件 _fm_5c4d_tj_into_5c4d_qk_sort_ 工料废统计结果.txt ” 对原始记录表中数据进行统计， 然后再排序处理。
（5） 条件文件的详解 “ 例 子 条 件 文 件 _fm_5c4d_tj_into_5c4d_qk_sort_ 工 料 废 统 计结果.txt ” 中的内容和解释。
1 概述在使用 Excel 的排序和分类汇总功能时， 发现其提供的排 序最大可用条件为 3 个， 分类汇总的指定条件仅为 1 个， 不能 满足更多条件设定的要求 。
故利用 Excel 中自带的 VB 编辑器 功能， 编写可使用多条件的排序和分类汇总的宏程序。
f m_5c4d_tj_i nto_5c4d_qk_sort.bas 是 根 据 “ 条 件 文 件 ” 中指定参数， 对源工作表中的指定起始行至最后行的数据按照 5 列条件进行分类汇总 4 列 数 据 ， 将 统 计 结 果 置入目的工作表中指定起始行， 5 列 条 件, 4 列 数 据 的 位 置 ， 再排序。
然 后 按 5 列 条 件 产品 A23 4 5 6 7 8 9 10 11 T 2teger 类型）‘源工作表的名称（string 类型） ‘源条件 1 的列号（integer 类型） ‘源条件 2 的列号（integer 类型） ‘源条件 3 的列号（integer 类型） ‘源条件 4 的列号（integer 类型） ‘源条件 5 的列号（integer 类型） ‘源数据 1 的列号（integer 类型） ‘源数据 2 的列号（integer 类型） ‘源数据 3 的列号（integer 类型） ‘源数据 4 的列号（integer 类型） ‘统计标记列的列号（integer 类型） ‘统计标记（string 类型）‘源工作表的开始统计起始行的行号（in-2 基本原理（1） 设计的提出计算计件数量要按照 不 同 产 品 、 不 同 工 序 、 不 同 产 品 型 号、 不同设备编号、 不同姓名进行分类统计， 然后在对统计后 的结果进行排序处理。
VBA汇总指定文件夹下的Excel文件数据
VBA汇总指定文件夹下的Excel文件数据本文链接：https:///Milong_xiao/article/details/79052002 案列：现需要按条件汇总一个文件夹下的多个Excel文件中的某列数据到汇总表格中，文件夹中的所有Excel文件都是基于一个模板，只是数据不同。
所有的Excel文件结构：库存组织:XXX 货主类型:XXX 货主:XXX起始日期:2017/12/23 截止日期:2017/12/23 物料范围:全部仓库范围:XXX 期初单价来源:XXX 收入发出单价来源:XXX K列L列物料编码物料名称仓库名称数量库存1.起始日期 = 截止日期，取K列值；2.起始日期！= 截止日期，取L列值；1.Sub Collect()2.Dim myPath, myFile, wk As Workbook, ws As Worksheet, ThisWs As Worksheet3.Dim ThisRowCount As Integer4.Dim AnotherRowCount As Integer5.Dim OutputColumn As Integer '输出数据所在的列；6.Dim test1, test2, test3, test4 'test fields;7.Dim StartDate As Date8.Dim EndDate As Date9.10.Application.ScreenUpdating = False '程序运行期间不刷新屏幕11.12.myPath = "D:\all\" '在这里输入你文件夹的路径，即你存放需要处理文件的文件夹；最后的“\”请一定加上！13.14.myFile = Dir(myPath & "*.xls") 'Dir(".xls")依次找寻指定路径中的.xls文件，如果是.xlsx的文件请改为.xlsx；“*”为通配符。
Excel VBA_多工作簿多工作表汇总实例集锦
Excel VBA_多工作簿多工作表汇总实例集锦excelvba_多工作簿多工作表汇总实例集锦1，多工作表汇总（consolidate）dimrangearray()asstringdimbkasworksheetdimshtasworksheetdimwbcountasintegerset bk=sheets(\汇总\wbcount=sheets.countredimrangearray(1towbcount-1)foreachshtinsheets<>\汇总\i=i+1rangearray(i)=\sht.range(\endifnextbk.range(\[a1].value=\姓名\endsubsubsumdemo()dimarrasvariantarr=array(\一月!r1c1:r8c5\二月!r1c1:r5c4\三月!r1c1:r9c6\withworksheets(\汇总\.consolidatearr,xlsum,true,true.value=\姓名\endwithendsub2，多工作簿汇总（consolidate）‘多工作簿汇总subconsolidateworkbook()dimrangearray()asstringdimbkasworkbookdimshtasworksheetdimwbcountasintegerwbcount=workbooks.countredimrangearray(1towbcount-1)foreachbkinworkbooks'在所有工作簿中循环ifnotbkisthisworkbookthen'非代码所在工作簿setsht=bk.worksheets(1)'提及工作簿的第一个工作表i=i+1rangearray(i)=\sht.range(\endifnextworksheets(1).range(\rangearray,xlsum,true,trueendsub3，多工作簿汇总（filesearch）'导入指定文件的数据dimmyfsasfilesearchdimmypathasstring,filename$dimiaslong,naslongdimsht1asworksheet,shasworksheetdimaa,nm$,nm1$,m,arr,r1,col1%application.scree nupdating=falsesetsht1=activesheetsetmyfs=application.filesearchmypath=thisworkbook.pathwithmyfs.newsearch.lookin=mypath.filetype=msofiletypenoteitem.filename=\if.execute(sortby:=msosortbyfilename)>0thenn=.foundfiles.countcol1=2redimmyfile(1ton)asstringfori=1tonmyfile(i)=.foundfiles(i)filename=myfile(i)aa=instrrev(filename,\nm=right(filename,len(filename)-aa)nm1=left(nm,len(nm)-4)ifnm1<>\汇总表\workbooks.openmyfile(i)dimwbasworkbooksetwb=activeworkbookm=[a65536].end(xlup) .rowarr=range(cells(3,3),cells(m,3))sht1.activatecol1=col1+1cells(2,col1)=nm'自动获取文件名cells(3,col1).resize(ubound(arr),1)=arrwb.closesavechanges:=falsesetwb=nothing endifnextelsemsgbox\该文件夹里没任何文件\endifendwith[a1].selectsetmyfs=nothingapplication.screenupdating=trueendsub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能publicar,ar1,nm$subpldrwb0531()'汇总表.xls'引入选定文件的数据（预设工作表1的数据）'轻易从c列依次引入dimmyfsasfilesearchdimmypathasstring,filename$dimiaslong,naslongdimsht1asworksheet,shasworksheetdimaa,nm1$,m,arr,r1,col1%application.screenupd ating=falseonerrorresumenextsetsht1=activesheetsetmyfs=application.filesearchmypath=thisworkbook.pathwithmyfs.newsearch.lookin=mypath.filetype=msofiletypenoteitem.filename=\if.execute(sortby:=msosortbyfilename)>0thenn=.foundfiles.count\+2,col1))100:col1=2redimmyfile(1ton)asstringfori=1tonmyfile(i)=.foundfiles(i)filename=myfile(i)aa=instrrev(filename,\nm=right(filename,len(filename)-aa)nm1=left(nm,len(nm)-4)ifnm1<>\汇总表\workbooks.openmyfile(i)dimwbasworkbooksetwb=activeworkbookforeachshinsheetss=s&&\nexts=left(s,len(s)-1)ar=split(s,\userform1.showforj=0toubound(ar1)iferr.number=9thengoto100setsh=wb.sheets(ar1(j))sh.activatem=sh.[a65536].end(xlup).rowarr=range(cells(3,3),cells(m,3))sht1.activatecol1=c ol1+1cells(2,col1)=sh.[a1]cells(3,col1).formular1c1=\&nm&\&ar1(j)&‘显示引用的工作簿工作表及单元格地址cells(3,col1).auto fillrange(cells(3,col1),cells(ubound(arr)‘cells(3,col1).res ize(ubound(arr),1)=arrnextjwb.closesavechanges:=falsesetwb=nothings=\ifvartype(ar1)=8200thenerasear1endifnextelsemsgbox\该文件夹里没任何文件\endifendwith[a1].selectsetmyfs=nothingapplication.screenupdating=trueendsubiflistbox1.selected(i)=truethens=s&listbox1.list(i)&\endifnextiifs<>\s=left(s,len(s)-1)ar1=split(s,\msgbox\你挑选了\unloaduserform1elsemg=msgbox(\你没有选择任何工作表！需要重新选择吗？ifmg=6thenelseunloaduserform1endifendifendsubendsubprivatesubuserform_initialize()withme.listbox1.list=ar‘文本框赋值.liststyle=1‘文本ka挑选大方框.multiselect=1‘设置可以多挑选\提示\。
excel vba 多条件筛选及汇总统计
excel vba 多条件筛选及汇总统计在Excel VBA中，您可以使用多种方法进行多条件筛选和汇总统计。
以下是一种常见的方法：1. 选择要筛选和汇总数据的范围。
```vbaDim rng As RangeSet rng = Range("A1:D10") '假设数据范围是A1:D10```2. 根据条件创建过滤器。
您可以使用`AutoFilter`方法来创建过滤器。
```vbarng.AutoFilter Field:=1, Criteria1:="条件1", Operator:=xlAnd '根据条件1筛选rng.AutoFilter Field:=2, Criteria1:="条件2", Operator:=xlAnd '根据条件2筛选'以此类推，根据需要添加更多条件```3. 计算筛选后的数据的汇总统计。
```vbaDim filteredData As RangeSet filteredData = rng.SpecialCells(xlCellTypeVisible) '筛选后的数据Dim sumCol As RangeSet sumCol = filteredData.Columns(4) '假设要汇总的数据在第四列Dim sumResult As DoublesumResult = WorksheetFunction.Sum(sumCol) '求和MsgBox "汇总结果: " & sumResult```上述代码将根据多个条件筛选数据，并计算筛选后数据的第四列的汇总结果。
您可以根据需要修改条件、数据范围和汇总列的位置。
请注意，上述代码假设您已经了解如何在VBA中编写基本的Excel代码，以及如何创建和调用宏。
如果您对此还不熟悉，您可能需要查阅更多的Excel VBA教程和文档。
excel通过VBA进行多条件统计
excel通过VBA进⾏多条件统计通过函数数组可以进⾏多条件查找，但是容易出错，⽽且很慢。
下⾯分享⼀条通过VBA实现多条件查找的经验给⼤家⼯具/原料EXCEL软件⽅法/步骤1. 1以商场2015年第⼀季度电器销售统计为例⼦，“产品”、“品牌”、“⽉份”3个条件的销售额进⾏查询。
2. 2假设要统计“康佳”的“1⽉”份“各类家电”的销售额，先建⼀个对应列的⼯作簿。
如图，输⼊条件1：“成品名称”，条件2:“品牌名称”，条件3：“⽉份”3. 3下⾯到了建⽴宏的步骤：单击菜单栏中的“开发⼯具”——插⼊——表单控件——按钮，在出现的⼗字箭头上拖住画出⼀个按钮，如图所⽰。
494. 4在弹出的查找红对话框中选择“录制”，在弹出的“录制新宏”对话框中，修改宏名称为“查找”，单击确定。
5. 5单击“开发⼯具”——查看代码，打开VBA编辑器，如图所⽰。
6. 6在VBA编辑器点击插⼊-模块，如图7. 7现在我们来输⼊代码：Sub 查找()Dim i As Integer, j As Integerarr1 = Sheets("数据").Range("A2:D" & Sheets("数据").Cells(Rows.Count, "A").End(xlUp).Row)arr2 = Sheets("查找").Range("A2:D" & Sheets("查找").Cells(Rows.Count, "A").End(xlUp).Row)For i = 1 To UBound(arr2)For j = 1 To UBound(arr1)If arr2(i, 1) = arr1(j, 1) And arr2(i, 2) = arr1(j, 2) And arr2(i, 3) = arr1(j, 3) Thenarr2(i, 4) = arr1(j, 4)GoTo 100End IfNextarr2(i, 4) = ""100:NextSheets("查找").Range("A2:D" & Sheets("查找").Cells(Rows.Count, "A").End(xlUp).Row) = arr2 End Sub8. 8现在回到EXCEL表格，右击按钮，选择“编辑⽂字”，修改按钮名称为“统计”。
VBA实现Excel多表格汇总
件 、若仅川 于 Ｏｆｉｃｅ２００７及 以 卜版本 ，＿『修 改第 １０和 ３０句 ．．
图 ２
相信操 作 Ｅｘｔ－ｅｌ的川 户大都 会遇 上多个 表 格汇总 ， 往往是在同一 个史什巾插入 多个 Ｓｈｅｅｔｓ并 复制上 分别要 汇总的表 格 ，再 川ｔ “∑”或公 式及 复制完成 有 多 个文件 、多个表格及 多个数据块 汇总时 如图 １分别是 总公 司存一个Ｔ作簿 史件 的 ３个汇 总表 ．其中各数据块 （Ａ—Ｃ数据 块 ）的 元格 数据 为 从 图 ２的 “分 公 司 １． ｘｌｓ”一 “分公 司 ６．ｘｌｓ” 中报 表 （报表 ｌ、报表 ２、报 表 ３）对应单元格 累加 的汇总 ，手 丁编辑时通 常是在 Ａ数 据块 的左 上单元 格输 入 “＝『分 公司 １．ｘｌｓ］报 表 ｌ！Ｂ４＋
４０ Ｅｎｄ Ｉｆ ５０ Ｆｏｒ ｉ＝２ Ｔｏ ＬａｓｔＳｈｅｅｔｓ
６０ Ｆｏｒ ｊ：１ Ｔｏ ７ ７０ Ｔ Ｓｔｒ＝ Ｍ ｉｄ（ ＩＶ： ７ ｊ）
＿
８０ Ｉｆ Ｉｎｓｔｒ（Ｒａｎｇｅ（“ｄ ＆ ｉ），Ｔ—Ｓｔｒ）Ｔｈｅｎ ９０ ＭｓｇＢｏｘ”表名错误 ！ＩＩ：Ｅｎｄ １ Ｏ０ Ｅｎｄ Ｉｆ １ １ Ｏ Ｎｅｘｔ １２０ ０ ｋ＝Ｔｒｕｅ １３０ Ｆｏｒ Ｅａｃｈ ｊ ｉｎ Ｓｈｅｅｔｓ １４０ Ｉｆ Ｔ Ｓｔｒ＝ｊ．Ｎａｍｅ Ｔｈｅｎ Ｏｋ＝一
１ ｉ分 公 司 名 是 否 汇 总
量一ｉ盆蛰蜀 — 经 ｉＬ盘——一
ｓ 公 司 ２ 待 忙 总
哇 ｉ分 公 司３ ｇ １分 公 司４
椿 ｝ｆ息 待 汇 总
６ ｝分 公 司 ５ ７ ：分 公 司 ６ ８ １
椿 汇 总 祷 奠
譬跬鞠黼龋瓣隅糟瓣麟 罐 §：
４０ Ｆｏｒ ｉ＝１ ＴＯ ９
VBA在多Excel工作薄数据汇总的应用
论文导读:：在工作中常对大量相同表结构的Excel工作薄进行汇总，利用手工复制、粘贴效率不高，本文探讨使用VBA 编程对多工作薄数据进行汇总。
关键词：VBA，相同表结构，多工作薄，数据汇总前言Microsoft Office软件是是微软公司开发的办公自动化应用软件，Microsoft Excel是其中的一个重要的组成部分，由于它包含大量的公式函数对各种大量数据有很强的处理、统计分析能力，广泛地应用于管理、统计、金融等领域。
伴随计算机的普及已经成为日常办公不可或缺的工具。
目前使用Excel支持VBA编程，VBA是Visual Basic For Application的简写，基于是基于VisualBasic for Windows 发展而来的。
在执行特定功能或重复性高的操作时，使用VBA 有助于使工作自动化相同表结构，提高工作效率会计毕业论文范文。
另外，由于VBA 可以直接应用Office 套装软件的各项强大功能，所以对于程序设计人员的程序设计和开发更加方便快捷。
1 需求分析在工作中经常会做数据的收集汇总，制定特定表结构的工作表供其它对象填写，然后回收汇总合并成一个完整表，主要采用手工打开工作表进行复制、粘贴这样简单而重复性较高的操作，容易使人疲惫导致操作错误，难以察觉，工作效率极低。
通过VBA可以高效、快速地编制出应用程序，高效完成工作任任务，而且在以后的工作中可以稍加修改或不用修改进行重复使用。
2 应用案例某高校每年都进行职业技能考试，各种类统一报名，班级按制定好格式的报名表填写报名（如图1、图2），之后由负责教师进行汇总成一个表（如图3）。
汇总的过程即为重复性的复制、粘贴。
本文即是利用VBA编程解决这样一类问题。
2.1 应用条件：工作表结构格式化各班级上交的登记表是考试报名要求的表结构格式是固定的、统一的相同表结构，只是各班报名人数不同，即表中的数据记录行数不同，数据填写在工作薄的第一张工作表中，与工作表名无关。
Excel VBA_多工作簿多工作表汇总实例集锦
1，多工作表汇总（Consolidate）‘/dispbbs.asp?boardID=5&ID=110630&page=1‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。
Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorksheetDim sht As WorksheetDim WbCount As IntegerSet bk = Sheets("汇总")WbCount = Sheets.CountReDim RangeArray(1 To WbCount - 1)For Each sht In SheetsIf <> "汇总" Theni = i + 1RangeArray(i) = "'" & & "'!" & _sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextbk.Range("A1").Consolidate RangeArray, xlSum, True, True[a1].Value = "姓名"End SubSub sumdemo()Dim arr As Variantarr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6") With Worksheets("汇总").Range("A1").Consolidate arr, xlSum, True, True.Value = "姓名"End WithEnd Sub2，多工作簿汇总（Consolidate）‘多工作簿汇总Sub ConsolidateWorkbook()Dim RangeArray() As StringDim bk As WorkbookDim sht As WorksheetDim WbCount As IntegerWbCount = Workbooks.CountReDim RangeArray(1 To WbCount - 1)For Each bk In Workbooks '在所有工作簿中循环If Not bk Is ThisWorkbook Then '非代码所在工作簿Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表i = i + 1RangeArray(i) = "'[" & & "]" & & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)End IfNextWorksheets(1).Range("A1").Consolidate _RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总（FileSearch）‘/thread-442007-1-1.html###‘help\汇总表.xlsSub pldrwb0531()'汇总表.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).Rowarr = Range(Cells(3, 3), Cells(m, 3))Sht1.Activatecol1 = col1 + 1Cells(2, col1) = nm '自动获取文件名Cells(3, col1).Resize(UBound(arr), 1) = arrwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$Sub pldrwb0531()'汇总表.xls'导入指定文件的数据（默认工作表1的数据）'直接从C列依次导入Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongDim Sht1 As Worksheet, sh As WorksheetDim aa, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "汇总表" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetss = s & & ","Nexts = Left(s, Len(s) - 1)ar = Split(s, ",")UserForm1.ShowFor j = 0 To UBound(ar1)If Err.Number = 9 Then GoTo 100Set sh = wb.Sheets(ar1(j))sh.Activatem = sh.[a65536].End(xlUp).Rowarr = Range(Cells(3, 3), Cells(m, 3))Sht1.Activatecol1 = col1 + 1Cells(2, col1) = sh.[a1]Cells(3, col1).FormulaR1C1 = "=[" & nm & "]" & ar1(j) & "!RC3" ‘显示引用的工作簿工作表及单元格地址Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))‘Cells(3, col1).Resize(UBound(arr), 1) = arrNext j100: wb.Close savechanges:=FalseSet wb = Nothings = ""If VarType(ar1) = 8200 Then Erase ar1End IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To ListBox1.ListCount - 1If ListBox1.Selected(i) = True Thens = s & ListBox1.List(i) & ","End IfNext iIf s <> "" Thens = Left(s, Len(s) - 1)ar1 = Split(s, ",")MsgBox "你选择了" & sUnload UserForm1Elsemg = MsgBox("你没有选择任何工作表！需要重新选择吗？", vbYesNo, "提示") If mg = 6 ThenElseUnload UserForm1End IfEnd IfEnd SubPrivate Sub CommandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBox1.List = ar ‘文本框赋值.ListStyle = 1 ‘文本前加选择小方框.MultiSelect = 1 ‘设置可多选End Withbel1.Caption = bel1.Caption & nmEnd Sub4，多工作表汇总（字典、数组）‘/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D 1‘Data多表汇总0623.xlsSub dbhz()'多表汇总Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As WorksheetDim d, k, t, Myr&, Arr, xApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet d = CreateObject("Scripting.Dictionary")For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字If InStr(, "-") > 0 Then Sht.Delete: GoTo 100nm = Mid(Sht.[a3], 7)d(nm) = ""100:Next ShtApplication.DisplayAlerts = Truek = d.keysFor i = 0 To UBound(k)Sheets.Add after:=Sheets(Sheets.Count)Set Sht1 = ActiveSheet = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In SheetsWith Sht.ActivateIf InStr(.Name, "-") = 0 Thennm = Replace(Mid(.[a3], 7), "/", "-")Myr = .[h65536].End(xlUp).RowArr = .Range("d10:h" & Myr)Set d = CreateObject("Scripting.Dictionary")For i = 1 To UBound(Arr)x = Arr(i, 1)If Not d.exists(x) Thend.Add x, Arr(i, 5)Elsed(x) = d(x) + Arr(i, 5)End IfNextk = d.keyst = d.itemsSet Sht2 = Sheets(nm)Sht2.Activatemyr2 = [a65536].End(xlUp).Row + 1If myr2 < 9 ThenCells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")Cells(10, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)Cells(10, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) ElseCells(myr2, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)Cells(myr2, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) End IfErase kErase tSet d = NothingEnd IfEnd WithNext ShtApplication.ScreenUpdating = TrueEnd Sub5，多工作簿提取指定数据（FileSearch）‘2011-8-31‘/thread-759188-1-1.htmlSub GetData()Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)Dim myFs As FileSearch, myfileDim myPath As String, Filename$, wbnm$Dim i&, n&, mm&, aa$, nm1$, j&Dim Sht1 As Worksheet, sh As Worksheet, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb1 = ThisWorkbookwbnm = Left(, Len() - 4)Set Sht1 = ActiveSheetSht1.[a2:w200] = ""aa = Left(, 2)Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\"With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0)If nm1 = wbnm Then GoTo 200Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsIf InStr(, aa) Thensh.ActivateIf aa = "班子" Thenmm = mm + 1Brrbz(mm, 1) = [b2].ValueFor j = 2 To 18 Step 2If j < 10 ThenBrrbz(mm, j) = Cells(j / 2 + 34, 11).ValueElseBrrbz(mm, j) = Cells(j / 2 + 34, 9).ValueEnd IfNextGoTo 100ElseIf [b2] = "" Then GoTo 50mm = mm + 1Brrgr(mm, 1) = [b2].ValueBrrgr(mm, 2) = [e38].ValueBrrgr(mm, 3) = [i38].ValueFor j = 4 To 18 Step 2If j < 12 ThenBrrgr(mm, j) = Cells(j / 2 + 38, 8).ValueElseBrrgr(mm, j) = Cells(j / 2 + 38, 7).ValueEnd IfNextFor j = 20 To 23Brrgr(mm, j) = Cells(j + 28, 8).ValueNextEnd IfEnd If50:Next100:wb.Close savechanges:=FalseSet wb = Nothing200:NextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithIf aa = "班子" Then[a2].Resize(mm, 19) = BrrbzElse[a2].Resize(mm, 23) = BrrgrEnd If[a1].SelectSet myFs = NothingEnd Sub‘2011-7-15‘/viewthread.php?tid=741341&pid=5036524&page=1&extra= Sub pldrsj()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, BrrDim myPath$, Filename$, nm2$Dim i&, j&, n&, aa$, nm$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetSht1.Cells.ClearContentsnm2 = Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim Brr(1 To n, 1 To 2)ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名If nm <> nm2 Thenj = j + 1Workbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.Sheets("Sheet1")Brr(j, 1) = nmBrr(j, 2) = sh.[c3].Valuewb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[a3].Resize(UBound(Brr), 2) = BrrSet myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()'/thread-456387-1-1.html'Report 2.xls'批量导入指定文件的数据Dim myFs As FileSearch, myfileDim myPath As String, Filename$, ma&, mc&Dim i As Long, n As Long, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheet: nn = 5Sht1.[b5:e27] = ""Set myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\data" ‘指定的子文件夹内搜索With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)nm1=split(mid(filename,instrrev(filename,"\")+1),".")(0) 一句代码代替以下3句‘aa = InStrRev(Filename, "\")‘nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名‘nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In Sheetssh.Activatema = [b65536].End(xlUp).RowIf ma > 6 Then ‘第6行是表头If ma > 10 Then ma = 10 ‘只要取4行数据For ii = 7 To maSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 6).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End Ifmc = [d65536].End(xlUp).RowIf mc > 7 Then ‘第7行是表头If mc > 11 Then mc = 11 ‘只要取4行数据For ii = 8 To mcSht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).ValueSht1.Cells(nn, 5) = Cells(ii, 8).Valuenn = nn + 1Next iiGoTo 100ElseGoTo 100End If100:Next shwb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D 2‘sum.xlsSub pldrsj0724()'批量导入指定文件的数据Dim myFs As FileSearch, myfile, Myr1&, ArrDim myPath$, Filename$, nm2$Dim i&, j&, n&, nn&, aa$, nm$, nm1$Dim Sht1 As Worksheet, sh As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = ActiveSheetMyr1 = Sht1.[a65536].End(xlUp).RowArr = Sht1.Range("a3:b" & Myr1)Sht1.Range("b3:b" & Myr1).ClearContentsnm2 = Left(, Len() - 4)Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名If nm1 <> nm2 ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookFor Each sh In SheetsFor j = 1 To UBound(Arr)If = Arr(j, 1) Thensh.ActivateSet r1 = Range("c:c").Find()nn = r1.RowArr(j, 2) = Cells(nn, 9)GoTo 100End IfNext jNext sh100:wb.Close savechanges:=FalseSet wb = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSht1.Select[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2)Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub6，多工作表提取指定数据（数组）‘/viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718 Sub fpkf()Application.ScreenUpdating = FalseDim Myr&, Arr, yf, x&, Myr1&, r1Dim Sht As WorksheetMyr = Sheet1.[b65536].End(xlUp).RowSheet1.Range("c8:h" & Myr).ClearContentsArr = Sheet1.Range("c8:h" & Myr)[j8].Formula = "=rc[-9]&""|""&rc[-8]"[j8].AutoFill Range("j8:j" & Myr)Range("j8:j" & Myr) = Range("j8:j" & Myr).ValueFor Each Sht In SheetsIf <> Thenyf = Left(, Len() - 2)Sht.ActivateMyr1 = [a65536].End(xlUp).Row - 1For x = 7 To Myr1If Cells(x, 1) <> "" ThenSet r1 = Sheet1.Range("j:j").Find(Cells(x, 1) & "|" & Cells(x, 2))If Not r1 Is Nothing ThenArr(r1.Row - 7, yf) = Cells(x, "ar")End IfEnd IfNext xEnd IfNextSheet1.Activate[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr[j:j].ClearApplication.ScreenUpdating = TrueEnd Sub7，多工作簿多工作表查询汇总去重复值（字典数组）‘/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D 1‘详细记录.xls‘3个工作簿需要都打开Sub xxjl()Dim Sht1 As Worksheet, Sht As WorksheetDim wb1 As Workbook, wb2 As Workbook, wb3 As WorkbookDim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$Application.ScreenUpdating = FalseSet wb1 = ActiveWorkbookSet wb2 = Workbooks("购进")Set wb3 = Workbooks("配料")wb2.ActivateMyr2 = [a65536].End(xlUp).RowArr2 = Range("a2:d" & Myr2)wb3.ActivateFor i = 1 To UBound(Arr2)wb3.Activatexm = Arr2(i, 2)For Each Sht In SheetsIf = xm ThenSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a1:b" & Myr)For j = 1 To UBound(Arr)yl = Arr(j, 1)wb1.ActivateFor Each Sht1 In SheetsIf = yl ThenSht1.ActivateMyr1 = [a65536].End(xlUp).Row + 1Cells(Myr1, 1) = Arr2(i, 1)Cells(Myr1, 3) = Arr2(i, 3)Cells(Myr1, 2) = Arr2(i, 4) * Arr(j, 2)Exit ForEnd IfNextNext jGoTo 100End IfNext100:Next iCall qccfApplication.ScreenUpdating = TrueEnd SubSub qccf()Dim Sht As Worksheet, Myr&, Arr, i&, xDim d, k, t, Arr1, j&Application.ScreenUpdating = FalseFor Each Sht In SheetsSht.ActivateMyr = [a65536].End(xlUp).RowArr = Range("a2:c" & Myr)Set d = CreateObject("Scripting.Dictionary")If Myr < 3 Then GoTo 100For i = 1 To UBound(Arr)x = Arr(i, 1) & "," & Arr(i, 3)If Not d.exists(x) Thend(x) = Arr(i, 2)Elsed(x) = d(x) + Arr(i, 2)End IfNextk = d.keyst = d.itemsReDim Arr1(1 To UBound(k) + 1, 1 To 3)For j = 0 To UBound(k)Arr1(j + 1, 1) = Split(k(j), ",")(0)Arr1(j + 1, 3) = Split(k(j), ",")(1)Arr1(j + 1, 2) = t(j)Next jRange("a2:c" & Myr).ClearContents[a2].Resize(UBound(Arr1), 3) = Arr1100:Set d = NothingNextApplication.ScreenUpdating = TrueEnd Sub8，多工作簿对比（FileSearch）‘/viewthread.php?tid=499599&pid=3285214&page=1&extra=page%3D1Sub dgzbdb()'多工作簿对比'by:蓝桥 2009-11-7Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, nm$, myfileDim Sht1 As Worksheet, sh As WorksheetDim wb1 As Workbook, yf, j&, m1&Dim m, arr, r1Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume NextSet wb1 = ThisWorkbookSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathFor Each Sht1 In SheetsIf InStr(Sht1.[a1], "费用明细表") > 0 Thennm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5)Sht1.ActivateWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = nm & ".xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenmyfile = .FoundFiles(1)Workbooks.Open myfileDim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.ActiveSheetm = sh.[a65536].End(xlUp).Rowarr = sh.Range(Cells(2, 1), Cells(m, 6))yf = Val(Split(arr(2, 1), ".")(1))Sht1.ActivateFor j = 1 To UBound(arr)Set r1 = Sht1.Range("c:c").Find(arr(j, 3))If r1 Is Nothing Thenm1 = Sht1.[d65536].End(xlUp).RowCells(m1, 1).EntireRow.Insert shift:=xlUp Cells(m1, 1) = Cells(m1 - 1, 1) + 1Cells(m1, 2) = arr(j, 3)Cells(m1, yf + 3) = arr(j, 6)End IfNext jwb.Close savechanges:=FalseSet wb = NothingEnd IfEnd WithEnd IfNextSet myFs = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub9，多工作簿汇总（FileSearch+字典）‘/viewthread.php?tid=504957&pid=3323070& page=1&extra=page%3D1Sub pldrwb1123()'合并.xls'导入指定文件的数据Dim myFs As FileSearchDim myPath As String, Filename$Dim i&, n&, y&, bb, j&, xDim Sht1 As Worksheet, sh As WorksheetDim aa, nm$, nm1$, m, Arr, r1, mm&Dim d, k, t, d1, t1Application.ScreenUpdating = Falsemm = 8Set Sht1 = ActiveSheetSht1.[a8:h1000].ClearContentsSet myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls".SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 <> "合并" ThenWorkbooks.Open myfile(i)Dim wb As WorkbookSet wb = ActiveWorkbookm = [a65536].End(xlUp).RowArr = Range(Cells(8, 1), Cells(m, 7))Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")For j = 1 To UBound(Arr)x = Year(Arr(j, 1)) & "年" & Month(Arr(j, 1)) & "月" & "|" & Arr(j, 2) & "|" & Arr(j, 3) & "|" & Arr(j, 5)d(x) = d(x) + Arr(j, 4)d1(x) = Arr(j, 7)Nextk = d.keyst = d.itemst1 = d1.itemsSht1.ActivateFor y = 0 To UBound(k)bb = Split(k(y), "|")Cells(mm, 1) = nm1Cells(mm, 2) = bb(0)Cells(mm, 3) = bb(1)Cells(mm, 4) = bb(2)Cells(mm, 5) = t(y)Cells(mm, 6) = bb(3)Cells(mm, 7) = t(y) * bb(3)Cells(mm, 8) = t1(y)mm = mm + 1Nextwb.Close savechanges:=FalseSet wb = NothingSet d = NothingSet d1 = NothingEnd IfNextElseMsgBox "该文件夹里没有任何文件"End IfEnd With[a1].SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Sub10，多工作簿多工作表提取数据（Do While）‘/viewthread.php?tid=511250&pid=3368549&page=1&extra=page%3D 1‘年度汇总.xlsSub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&Application.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "年度汇总.xls"myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Arr = .Sheets("领料").Range("A1").CurrentRegionFor Each sh In wb.Sheetsshnm = sh.ActivateIf InStr(shnm, "班") > 0 Thencol = 11Elsecol = 7End IfFor i = 2 To UBound(Arr)If Arr(i, col) = shnm Thenm = sh.[a65536].End(xlUp).Row + 1Cells(m, 1).Resize(1, 12) = Application.Index(Arr, i, 0)End IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&page=1#pid4261137Sub tqsj()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$Application.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheet[a2:g1000].ClearContentsfunm = "提取数据.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Activatepm = sh.[a4].ValueMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("b9:e" & Myr)m = m + 1With Sht1.Cells(m, 1) = myName.Cells(m, 2) = pm.Cells(m, 3) = shnm.Cells(m, 4).Resize(UBound(Arr), 4) = ArrEnd Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=521786&pid=3439524&page=1&extra=page%3D 1‘我想要的结果.xlsSub zdgx()Dim Arr, myPath$, myName$, sh As WorksheetDim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = "我想要的结果.xls"Set Sht = ActiveSheetSht.[a2:f1000].ClearContentsSht.[a2:f1000].Borders.LineStyle = xlNonemyPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")n = 2Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set sh = .Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowArr = sh.Range("a2:f" & m)Cells(n, 1).Resize(m - 1, 6) = Arrn = n + m - 1.Close FalseEnd WithmyName = DirLoopSht.Range("a2:f" & n - 1).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub‘/dispbbs.asp?boardid=5&id=113181&star=1#1455753‘汇总工作表.xls 2010-2-7Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = m + 1Sht1.Cells(m, 1).Resize(1, 3) = Application.Index(Arr, i, 0)Sht1.Cells(m, 4) = Arr(i + 1, 3)Sht1.Cells(m, 5) = Arr(i + 2, 3)Sht1.Cells(m, 6) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=629755&pid=4261137&page=1&extra=page%3D 1Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = "汇总工作表.xls": m = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.ActivateMyr = sh.[a65536].End(xlUp).RowArr = sh.Range("a1:c" & Myr)For i = 1 To UBound(Arr)If Arr(i, 3) > 50 Thenm = m + 1Sht1.Cells(m, 1).Resize(1, 3) = Application.Index(Arr, i, 0)Sht1.Cells(m, 4) = Arr(i + 1, 3)Sht1.Cells(m, 5) = Arr(i + 2, 3)Sht1.Cells(m, 6) = shnmEnd IfNextNext.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Sub‘/thread-539493-1-1.htmlSub ndhz() ‘设置工作表在此处要用Sheets("汇总")格式Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, n%, i&, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = "汇总.xls": n = 1myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xls")wb.Sheets("汇总").[a2:e100].ClearDo While myName <> "" And myName <> funmWith GetObject(myPath & myName)Set wb1 = Workbooks(myName)Set sh = wb1.Sheets("Sheet1")m = sh.[a65536].End(xlUp).RowWith wb.Sheets("汇总")n = n + 1.Cells(n, 1) = sh.[b2].Value.Cells(n, 2) = sh.[c2].Value.Cells(n, 3) = Application.Sum(sh.[e2].Resize(m - 1, 1)).Cells(n, 4) = Application.Sum(sh.[f2].Resize(m - 1, 1)).Cells(n, 5) = Application.Sum(sh.[g2].Resize(m - 1, 1)) End With.Close FalseEnd WithmyName = DirLoopwb.Sheets("汇总").Range("a2:e" & n).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub'/thread-580459-1-1.html‘ABC.xls 2010-5-28Sub dgzbsj()Dim Arr, i&, sh$, n&, myPath$, shnm$, nm$, ad$Dim Sht As Worksheet, m&, Arr1, r1On Error Resume NextApplication.ScreenUpdating = False。
excel多条件满足统计汇总
excel多条件满足统计汇总Excel是一款功能强大的电子表格软件，可以对数据进行多条件满足统计和汇总。
本文将介绍如何使用Excel进行多条件满足统计和汇总，并详细解释相关操作步骤和注意事项。
我们需要明确什么是多条件满足统计和汇总。
在Excel中，多条件满足统计和汇总是指根据多个条件对数据进行筛选和统计，以便得出所需的结果。
下面以一个实际案例来说明。
假设我们有一份销售数据表格，其中包含了产品名称、销售数量和销售金额等信息。
我们希望统计某个产品在某个时间段内的销售数量和销售金额，同时满足以下条件：产品名称为A，销售数量大于100，销售金额大于1000。
我们需要在表格中创建一个新的区域，用于输入条件参数。
我们可以将条件参数分别输入到不同的单元格中，例如将产品名称输入到A1单元格，销售数量大于100输入到B1单元格，销售金额大于1000输入到C1单元格。
接下来，我们需要使用Excel的筛选功能来满足条件筛选的需求。
首先选中整个数据表格，然后点击Excel菜单栏中的“数据”选项卡，在“排序和筛选”功能组中选择“筛选”按钮。
此时，每一列的标题栏上都会出现筛选的小箭头。
我们需要依次点击产品名称、销售数量和销售金额三列标题栏上的筛选小箭头，然后选择“筛选”选项。
在弹出的筛选窗口中，选择“自定义筛选”选项，并在相应的条件输入框中输入条件参数。
以产品名称为例，我们选择“等于”条件，并在输入框中输入A。
对于销售数量和销售金额，我们选择“大于”条件，并分别输入100和1000。
点击“确定”按钮后，Excel会根据我们设置的条件对数据进行筛选，并只显示满足条件的数据行。
此时，我们可以看到只有满足产品名称为A，销售数量大于100，销售金额大于1000的数据行被显示出来。
接下来，我们需要统计满足条件的销售数量和销售金额。
在数据表格下方的空白行中，可以使用Excel的内置函数来实现统计功能。
在销售数量的统计单元格中，我们可以使用“SUM”函数来对满足条件的销售数量进行求和。