1、1，多工作表匯總（Consolidate）/dispbbs.asp?boardID=5&ID=&page=1兩種寫法都要求地址用R1C1形式，各個表格的數據布置有規定。Sub ConsolidateWorkbook() Dim RangeArray() As String Dim bk As Worksheet Dim sht As Worksheet Dim WbCount As Integer Set bk = Sheets(匯總) WbCount = Sheets.Count ReDim RangeArray(1 To WbCount - 1)

2、For Each sht In Sheets If sht.Name 匯總 Then i = i + 1 RangeArray(i) = & sht.Name & ! & _ sht.Range(A1).CurrentRegion.Address(ReferenceStyle:=xlR1C1) End If Next bk.Range(A1).Consolidate RangeArray, xlSum, True, True a1.Value = 姓名 End SubSub sumdemo()Dim arr As Variant arr = Array(一月!R1C1:R8C5, 二月!R1C

3、1:R5C4, 三月!R1C1:R9C6) With Worksheets(匯總).Range(A1) .Consolidate arr, xlSum, True, True .Value = 姓名 End WithEnd Sub2，多工作簿匯總（Consolidate）多工作簿匯總Sub ConsolidateWorkbook() Dim RangeArray() As String Dim bk As Workbook Dim sht As Worksheet Dim WbCount As Integer WbCount = Workbooks.Count ReDim RangeArray

4、(1 To WbCount - 1) For Each bk In Workbooks 在所有工作簿中循環 If Not bk Is ThisWorkbook Then 非代碼所在工作簿 Set sht = bk.Worksheets(1) 引用工作簿的第一個工作表 i = i + 1 RangeArray(i) = & bk.Name & & sht.Name & ! & _ sht.Range(A1).CurrentRegion.Address(ReferenceStyle:=xlR1C1) End If Next Worksheets(1).Range(A1).Consolidate _

5、 RangeArray, xlSum, True, TrueEnd Sub3，多工作簿匯總（FileSearch）/thread-1-1.html#help匯總表.xlsSub pldrwb0531()匯總表.xls導入指定文件的數據 Dim myFs As FileSearch Dim myPath As String, Filename$ Dim i As Long, n As Long Dim Sht1 As Worksheet, sh As Worksheet Dim aa, nm$, nm1$, m, arr, r1, col1%App

6、lication.ScreenUpdating = FalseSet Sht1 = ActiveSheet Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.xls If .Execute(SortBy:=msoSortByFileName) 0 Then n = .FoundFiles.Count col1 = 2 ReDim myfile(1 To n)

7、 As String For i = 1 To n myfile(i) = .FoundFiles(i) Filename = myfile(i) aa = InStrRev(Filename, ) nm = Right(Filename, Len(Filename) - aa) nm1 = Left(nm, Len(nm) - 4) If nm1 匯總表 Then Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook m = a65536.End(xlUp).Row arr = Range(Cells(3, 3

8、), Cells(m, 3) Sht1.Activate col1 = col1 + 1 Cells(2, col1) = nm 自動獲取文件名 Cells(3, col1).Resize(UBound(arr), 1) = arr wb.Close savechanges:=False Set wb = Nothing End If Next Else MsgBox 該文件夾里沒有任何文件 End If End With a1.Select Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub根據上例增加了在一個工作簿中可選擇多

9、個工作表進行匯總，運用了文本框多選功能Public ar, ar1, nm$Sub pldrwb0531()匯總表.xls導入指定文件的數據（默認工作表1的數據）直接從C列依次導入 Dim myFs As FileSearch Dim myPath As String, Filename$ Dim i As Long, n As Long Dim Sht1 As Worksheet, sh As Worksheet Dim aa, nm1$, m, arr, r1, col1%Application.ScreenUpdating = FalseOn Error Resume NextSet S

10、ht1 = ActiveSheet Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.xls If .Execute(SortBy:=msoSortByFileName) 0 Then n = .FoundFiles.Count col1 = 2 ReDim myfile(1 To n) As String For i = 1 To n myfile(i)

11、= .FoundFiles(i) Filename = myfile(i) aa = InStrRev(Filename, ) nm = Right(Filename, Len(Filename) - aa) nm1 = Left(nm, Len(nm) - 4) If nm1 匯總表 Then Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook For Each sh In Sheets s = s & sh.Name & , Next s = Left(s, Len(s) - 1) ar = Split(s

12、, ,) UserForm1.Show For j = 0 To UBound(ar1) If Err.Number = 9 Then GoTo 100 Set sh = wb.Sheets(ar1(j) sh.Activate m = sh.a65536.End(xlUp).Row arr = Range(Cells(3, 3), Cells(m, 3) Sht1.Activate col1 = col1 + 1 Cells(2, col1) = sh.a1 Cells(3, col1).FormulaR1C1 = = & nm & & ar1(j) & !RC3 顯示引用的工作簿工作表及單

13、元格地址 Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1) Cells(3, col1).Resize(UBound(arr), 1) = arr Next j100: wb.Close savechanges:=False Set wb = Nothing s = If VarType(ar1) = 8200 Then Erase ar1 End If Next Else MsgBox 該文件夾里沒有任何文件 End If End With a1.Select Set myFs = Nothi

14、ngApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then s = s & ListBox1.List(i) & , End IfNext iIf s Thens = Left(s, Len(s) - 1)ar1 = Split(s, ,)MsgBox 你選擇了 & sUnload UserForm1Elsemg = MsgBox(你沒有選擇任何工作表！需要重新

15、選擇嗎？ , vbYesNo, 提示)If mg = 6 ThenElse Unload UserForm1End IfEnd 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，

16、多工作表匯總（字典、數組）/viewthread.php?tid=&pid=&page=1&extra=page%3D1Data多表匯總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.Dicti

17、onary)For Each Sht In Sheets 刪除同名的表格，獲得要增加的匯總表格不重復名字 If InStr(Sht.Name, -) 0 Then Sht.Delete: GoTo 100 nm = 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 Sht1.Name = Replace(k(i), /, -

18、) 增加匯總表，把名字中的”/”（不能用作表名的）改為”-“Next iErase kSet d = NothingFor Each Sht In Sheets With Sht .Activate If InStr(.Name, -) = 0 Then nm = Replace(Mid(.a3, 7), /, -) Myr = .h65536.End(xlUp).Row Arr = .Range(d10:h & Myr) Set d = CreateObject(Scripting.Dictionary) For i = 1 To UBound(Arr) x = Arr(i, 1) If N

19、ot d.exists(x) Then d.Add x, Arr(i, 5) Else d(x) = d(x) + Arr(i, 5) End If Next k = d.keys t = d.items Set Sht2 = Sheets(nm) Sht2.Activate myr2 = a65536.End(xlUp).Row + 1 If myr2 0 Then n = .FoundFiles.Count ReDim myfile(1 To n) As String For i = 1 To n myfile(i) = .FoundFiles(i) Filename = myfile(i

20、) nm1 = Split(Mid(Filename, InStrRev(Filename, ) + 1), .)(0) If nm1 = wbnm Then GoTo 200 Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook For Each sh In Sheets If InStr(sh.Name, aa) Then sh.Activate If aa = 班子 Then mm = mm + 1 Brrbz(mm, 1) = b2.Value For j = 2 To 18 Step 2 If j 10

21、 Then Brrbz(mm, j) = Cells(j / 2 + 34, 11).Value Else Brrbz(mm, j) = Cells(j / 2 + 34, 9).Value End If Next GoTo 100 Else If b2 = Then GoTo 50 mm = mm + 1 Brrgr(mm, 1) = b2.Value Brrgr(mm, 2) = e38.Value Brrgr(mm, 3) = i38.Value For j = 4 To 18 Step 2 If j 0 Then n = .FoundFiles.Count ReDim Brr(1 To

22、 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(Sh

23、eet1) 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()/thread-1-1.html

24、Report 2.xls批量導入指定文件的數據 Dim myFs As FileSearch, myfile Dim myPath As String, Filename$, ma&, mc& Dim i As Long, n As Long, nn&, aa$, nm$, nm1$ Dim Sht1 As Worksheet, sh As Worksheet Application.ScreenUpdating = False Set Sht1 = ActiveSheet: nn = 5 Sht1.b5:e27 = Set myFs = Application.FileSearch myPa

25、th = ThisWorkbook.Path & data 指定的子文件夾內搜索 With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.xls .SearchSubFolders = True If .Execute(SortBy:=msoSortByFileName) 0 Then n = .FoundFiles.Count ReDim myfile(1 To n) As String For i = 1 To n myfile(i) = .FoundFiles(i) Filen

26、ame = 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 Sht1.Name Then Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook For Each s

27、h In Sheets sh.Activate ma = b65536.End(xlUp).Row If ma 6 Then 第6行是表頭 If ma 10 Then ma = 10 只要取4行數據 For ii = 7 To ma Sht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).Value Sht1.Cells(nn, 5) = Cells(ii, 6).Value nn = nn + 1 Next ii GoTo 100 Else GoTo 100 End If mc = d65536.End(xlUp).Row If

28、mc 7 Then 第7行是表頭 If mc 11 Then mc = 11 只要取4行數據 For ii = 8 To mc Sht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).Value Sht1.Cells(nn, 5) = Cells(ii, 8).Value nn = nn + 1 Next ii GoTo 100 Else GoTo 100 End If100: Next sh wb.Close savechanges:=False Set wb = Nothing End If Next Else MsgBox 該

29、文件夾里沒有任何文件 End If End With a1.Select Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub/viewthread.php?tid=&pid=&page=1&extra=page%3D2sum.xlsSub pldrsj0724()批量導入指定文件的數據 Dim myFs As FileSearch, myfile, Myr1&, Arr Dim myPath$, Filename$, nm2$ Dim i&, j&, n&, nn&, aa$, n

30、m$, nm1$ Dim Sht1 As Worksheet, sh As Worksheet Application.ScreenUpdating = False Set Sht1 = ActiveSheet Myr1 = Sht1.a65536.End(xlUp).Row Arr = Sht1.Range(a3:b & Myr1) Sht1.Range(b3:b & Myr1).ClearContents nm2 = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) Set myFs = Application.FileSear

31、ch myPath = ThisWorkbook.Path With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.xls If .Execute(SortBy:=msoSortByFileName) 0 Then n = .FoundFiles.Count ReDim myfile(1 To n) As String For i = 1 To n myfile(i) = .FoundFiles(i) Filename = myfile(i) aa = InStrRev(Filena

32、me, ) nm = Right(Filename, Len(Filename) - aa) 帶后綴的Excel文件名 nm1 = Left(nm, Len(nm) - 4) 去除后綴的Excel文件名 If nm1 nm2 Then Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook For Each sh In Sheets For j = 1 To UBound(Arr) If sh.Name = Arr(j, 1) Then sh.Activate Set r1 = Range(c:c).Find(sh.Name) nn = r1.Row Arr(j, 2) = Cells(nn, 9) GoTo 100 End If Next j Next sh100: wb.Close savechanges:=False Set wb = Nothing End If Next Else MsgBox 該文件夾里沒有任何文件 End If End With Sht1.Select b3.Resize(UBound(Arr), 1) = Application.Inde