1、1，多工作表汇总（Consolidate ）http:/ 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 sht.Name 0 Thenn = .FoundFiles.Count
2、col1 = 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 0 Thenn = .FoundFiles.Countcol1 = 2ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles
3、(i)Filename = myfile(i)aa = InStrRev(Filename, “)nm = Right(Filename, Len(Filename) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 “ Thens = Left(s, Len(s) - 1)ar1 = Split(s, “,“)MsgBox “你选择了 “ & sUnload UserForm1Elsemg = MsgBox(“你没有选择任何工作表！需要重新选择吗？ “, vbYesNo, “提示“)If mg = 6 ThenElseUnload UserForm1End IfE
4、nd IfEnd SubPrivate Sub CommandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBox1.List = ar 文本框赋值.ListStyle = 1 文本前加选择小方框.MultiSelect = 1 设置可多选End WithMe.Label1.Caption = Me.Label1.Caption & nmEnd Sub4，多工作表汇总（字典、数组）http:/ 多表汇总 0623.xlsSub dbhz()多表汇总Dim Sht1 As Wo
5、rksheet, 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(Sht.Name, “-“) 0 Then Sht.Delete: GoTo 100nm = Mid(Sht.a3, 7)d(nm
6、) = “100:Next ShtApplication.DisplayAlerts = Truek = d.keysFor i = 0 To UBound(k)Sheets.Add after:=Sheets(Sheets.Count)Set Sht1 = ActiveSheetSht1.Name = Replace(k(i), “/“, “-“) 增加汇总表，把名字中的 ”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In SheetsWith Sht.ActivateIf InStr(.Name, “-“) = 0 Th
7、ennm = 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.Act
8、ivatemyr2 = a65536.End(xlUp).Row + 1If myr2 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 =
9、ActiveWorkbookFor Each sh In SheetsIf InStr(sh.Name, aa) Thensh.ActivateIf aa = “班子“ Thenmm = mm + 1Brrbz(mm, 1) = b2.ValueFor j = 2 To 18 Step 2If j 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 = InS
10、trRev(Filename, “)nm = Right(Filename, Len(Filename) - aa) 带后缀的 Excel 文件名If nm 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(
11、Filename, Len(Filename) - aa) 带后缀的 Excel 文件名nm1 = Left(nm, Len(nm) - 4) 去除后缀的 Excel 文件名If nm1 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
12、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 I
13、fNextElseMsgBox “该文件夹里没有任何文件“End IfEnd Witha1.SelectSet myFs = NothingApplication.ScreenUpdating = TrueEnd Subhttp:/ 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.Scree
14、nUpdating = FalseSet Sht1 = ActiveSheetMyr1 = Sht1.a65536.End(xlUp).RowArr = Sht1.Range(“a3:b“ & Myr1)Sht1.Range(“b3:b“ & Myr1).ClearContentsnm2 = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)Set myFs = Application.FileSearchmyPath = ThisWorkbook.PathWith myFs.NewSearch.LookIn = myPath.Fil
15、eType = 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, Le
16、n(nm) - 4) 去除后缀的 Excel 文件名If nm1 Sheet1.Name Thenyf = Left(Sht.Name, Len(Sht.Name) - 2)Sht.ActivateMyr1 = a65536.End(xlUp).Row - 1For x = 7 To Myr1If Cells(x, 1) 0 Thenmyfile = .FoundFiles(1)Workbooks.Open myfileDim wb As WorkbookSet wb = ActiveWorkbookSet sh = wb.ActiveSheetm = sh.a65536.End(xlUp).
17、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:=xlUpCells(m1, 1) = Cells(m1 - 1, 1) + 1Cells(m1, 2) = arr(j
18、, 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+ 字典）http:/ pldrwb1123()合并.xls导入指定文件的数据Dim myFs As FileSearchDim myPath As Stri
19、ng, 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.Loo
20、kIn = 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(Filenam
21、e) - aa)nm1 = Left(nm, Len(nm) - 4)If nm1 “ And myName 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
22、= TrueEnd Subhttp:/ 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 = ActiveSheeta2:g1000.ClearContentsfunm = “提取数据.xls“: m = 1myPath = ThisWorkbook.Path & “myNa
23、me = Dir(myPath & “*.xls“)Do While myName funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Namesh.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
24、.Cells(m, 4).Resize(UBound(Arr), 4) = ArrEnd Withm = m + UBound(Arr) - 1Next.Close FalseEnd WithmyName = DirLoopApplication.ScreenUpdating = TrueEnd Subhttp:/ zdgx()Dim Arr, myPath$, myName$, sh As WorksheetDim m&, funm$, n&, Sht As WorksheetApplication.ScreenUpdating = Falsefunm = “我想要的结果.xls“Set S
25、ht = ActiveSheetSht.a2:f1000.ClearContentsSht.a2:f1000.Borders.LineStyle = xlNonemyPath = ThisWorkbook.Path & “myName = Dir(myPath & “*.xls“)n = 2Do While 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
26、, 6) = Arrn = n + m - 1.Close FalseEnd WithmyName = DirLoopSht.Range(“a2:f“ & n - 1).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Subhttp:/ 2010-2-7Sub ndhz()Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As WorksheetApplication.Scre
27、enUpdating = FalseOn Error Resume NextSet Sht1 = ActiveSheetfunm = “汇总工作表.xls“: m = 1myPath = ThisWorkbook.Path & “myName = Dir(myPath & “*.xls“)Do While myName funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Namesh.ActivateMyr = sh.a65536.End(xlUp).Row
28、Arr = 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.ScreenUpda
29、ting = TrueEnd Subhttp:/ 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 & “*.
30、xls“)Do While myName funmWith GetObject(myPath & myName)Set wb = Workbooks(myName)For Each sh In wb.Sheetsshnm = sh.Namesh.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
31、)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 Subhttp:/ ndhz() 设置工作表在此处要用 Sheets(“汇总“) 格式Dim Arr, myPath$, myName$, wb As Workbook, sh As WorksheetDim m&, funm$, shnm$, n%
32、, i&, wb1 As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookfunm = “汇总.xls“: n = 1myPath = ThisWorkbook.Path & “myName = Dir(myPath & “*.xls“)wb.Sheets(“汇总“).a2:e100.ClearDo While myName funmWith GetObject(myPath & myName)Set wb1 = Workbooks(myName)Set sh = wb1.Sheets(“Sheet1“)m = sh
33、.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 = Di
34、rLoopwb.Sheets(“汇总“).Range(“a2:e“ & n).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Subhttp:/ 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
35、(myPath & “*.xls“)While Not Len(sh) = 0If sh “If myName 1 Then Exit SubIf Target.Address nm And st.Name “提示“ ThenSet r1 = Sheets(nm).Cells.Find(st.Name, , , 1)If Not r1 Is Nothing Thenad = r1.Address 表格名的地址sul = Sheets(nm).Range(ad).Offset(1, 0) 投产的数量If sul 0 ThenFor i = 3 To st.b65536.End(3).Rowd(“ & st.Cells(i, 3) = d(“ & st.Cells(i, 3) + st.Cells(i, 4) * sulNext iEnd If
