Excel VBA_多工作簿多工作表汇总实例集锦参考模板

1、1，多工作表汇总（Consolidate）两种写法都要求地址用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) For Each sht In Sheets If sht.Name 汇总 Then i = i + 1 R

2、angeArray(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, 二月!R1C1:R5C4, 三月!R1C1:R9C6) With Worksheets(汇总).Range(A1) .C

3、onsolidate arr, xlSum, True, True .Value = 姓名 End WithEnd Sub2，多工作簿汇总（Consolidate）多工作簿汇总Sub ConsolidateWorkbook() Dim RangeArray() As String1 / 92 Dim bk As Workbook Dim sht As Worksheet Dim WbCount As Integer WbCount = Workbooks.Count ReDim RangeArray(1 To WbCount - 1) For Each bk In Workbooks 在所有工

4、作簿中循环 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 _ RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总（Fi

5、leSearch）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%Application.ScreenUpdating = FalseSet Sht1 = ActiveSheet Set myFs = Application.FileSearch m

6、yPath = 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) = .FoundFiles(i) Filename = myfile(i) aa = InStrRev(F

7、ilename, ) 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), Cells(m, 3) Sht1.Activate col1 = col1 + 1 Cells(2, col1) = nm 自动获取文件名 Cells(3, col1).R

8、esize(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根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$Sub pldrwb0531()汇总表.xls导入指定文件的数据（默认工作表1的数据）直接从C列依次导

9、入 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 Sht1 = ActiveSheet Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs

10、.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) = .FoundFiles(i) Filename = myfile(i) aa = InStrRev(Filename, ) nm = Right(Filename, Len(

11、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, ,) UserForm1.Show For j = 0 To UBound(ar1) If Err.Number = 9 Then GoTo 100 Set sh = wb.

12、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 显示引用的工作簿工作表及单元格地址 Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1) Cells(3,

13、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 = NothingApplication.ScreenUpdating = TrueEnd SubPrivate Sub CommandButton1_Click()For i = 0 To

14、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(你没有选择任何工作表！需要重新选择吗？ , vbYesNo, 提示)If mg = 6 ThenElse Unload UserForm1End IfEnd IfEnd SubPrivate Sub Comm

15、andButton2_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，多工作表汇总（字典、数组）Data多表汇总0623.xlsSub dbhz()多表汇总Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht

16、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 100 nm = Mid(Sht.a3, 7) d(nm) = 100:Next ShtApplication.Displ

17、ayAlerts = Truek = d.keysFor i = 0 To UBound(k) Sheets.Add after:=Sheets(Sheets.Count) Set Sht1 = ActiveSheet Sht1.Name = Replace(k(i), /, -) 增加汇总表，把名字中的”/”（不能用作表名的）改为”-“Next iErase kSet d = NothingFor Each Sht In Sheets With Sht .Activate If InStr(.Name, -) = 0 Then nm = Replace(Mid(.a3, 7), /, -)

18、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 Not 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(xlU

19、p).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) 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

20、 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 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

21、(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 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(Fil

22、ename) - 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.Res

23、ize(UBound(Brr), 2) = Brr Set myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()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.Screen

24、Updating = False Set Sht1 = ActiveSheet: nn = 5 Sht1.b5:e27 = Set myFs = Application.FileSearch myPath = ThisWorkbook.Path & data 指定的子文件夹内搜索 With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.xls .SearchSubFolders = True If .Execute(SortBy:=msoSortByFileName) 0 Then

25、n = .FoundFiles.Count ReDim myfile(1 To n) As String For i = 1 To n myfile(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文件名

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

27、= Cells(ii, 6).Value nn = nn + 1 Next ii GoTo 100 Else GoTo 100 End If mc = d65536.End(xlUp).Row If 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 Els

28、e GoTo 100 End If100: Next sh wb.Close savechanges:=False Set wb = Nothing End If Next Else MsgBox 该文件夹里没有任何文件 End If End With a1.Select Set myFs = NothingApplication.ScreenUpdating = TrueEnd Subsum.xlsSub pldrsj0724()批量导入指定文件的数据 Dim myFs As FileSearch, myfile, Myr1&, Arr Dim myPath$, Filename$, nm2

29、$ Dim i&, j&, n&, nn&, aa$, nm$, 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) Se

30、t myFs = Application.FileSearch 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 = m

31、yfile(i) aa = InStrRev(Filename, ) 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) = C