ExcelVBA多工作簿多工作表汇总实例集锦

《ExcelVBA多工作簿多工作表汇总实例集锦》由会员分享，可在线阅读，更多相关《ExcelVBA多工作簿多工作表汇总实例集锦（80页珍藏版）》请在装配图网上搜索。

1、.1，多工作表汇总Consolidate.e*celp*./dispbbs.asp?boardID=5&ID=110630&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) For Eac

2、h sht In Sheets If sht.Name 汇总 Then i = i + 1 RangeArray(i) = & sht.Name & ! & _ sht.Range(A1).CurrentRegion.Address(ReferenceStyle:=*lR1C1) End If Ne*t bk.Range(A1).Consolidate RangeArray, *lSum, True, True a1.Value = End SubSub sumdemo()Dim arr As Variant arr = Array(一月!R1C1:R8C5, 二月!R1C1:R5C4, 三月

3、!R1C1:R9C6) With Worksheets(汇总).Range(A1) .Consolidate arr, *lSum, 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(1 To WbCount -

4、 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:=*lR1C1) End If Ne*t Worksheets(1).Range(A1).Consolidate _ RangeArray, *l

5、Sum, True, TrueEnd Sub3，多工作簿汇总FileSearch2007-1-1.html*help汇总表.*lsSub pldrwb0531()汇总表.*ls导入指定文件的数据 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 = Ac

6、tiveSheet Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.*ls If .E*ecute(SortBy:=msoSortByFileName) 0 Then n = .FoundFiles.Count col1 = 2 ReDim myfile(1 To n) As String For i = 1 To n myfile(i) = .Found

7、Files(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(*lUp).Row arr = Range(Cells(3, 3), Cells(m, 3) Sht1.Activate col1 = col1 + 1

8、 Cells(2, col1) = nm 自动获取文件名 Cells(3, col1).Resize(UBound(arr), 1) = arr wb.Close savechanges:=False Set wb = Nothing End If Ne*t Else MsgBo* 该文件夹里没有任何文件 End If End With a1.Select Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub根据上例增加了在一个工作簿中可选择多个工作表进展汇总，运用了文本框多项选择功能Public ar, ar1, nm$Sub

9、pldrwb0531()汇总表.*ls导入指定文件的数据默认工作表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 Ne*tSet Sht1 = ActiveSheet Set myFs = Application.Fil

10、eSearch myPath = ThisWorkbook.Path With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.*ls If .E*ecute(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 = I

11、nStrRev(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 & , Ne*t s = Left(s, Len(s) - 1) ar = Split(s, ,) UserForm1.Show For j = 0 To UBound(ar1)

12、 If Err.Number = 9 Then GoTo 100 Set sh = wb.Sheets(ar1(j) sh.Activate m = sh.a65536.End(*lUp).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, c

13、ol1), Cells(UBound(arr) + 2, col1)Cells(3, col1).Resize(UBound(arr), 1) = arr Ne*t j100: wb.Close savechanges:=False Set wb = Nothing s = If VarType(ar1) = 8200 Then Erase ar1 End If Ne*t Else MsgBo* 该文件夹里没有任何文件 End If End With a1.Select Set myFs = NothingApplication.ScreenUpdating = TrueEnd SubPriv

14、ate Sub mandButton1_Click()For i = 0 To ListBo*1.ListCount - 1 If ListBo*1.Selected(i) = True Then s = s & ListBo*1.List(i) & , End IfNe*t iIf s Thens = Left(s, Len(s) - 1)ar1 = Split(s, ,)MsgBo* 你选择了 & sUnload UserForm1Elsemg = MsgBo*(你没有选择任何工作表！需要重新选择吗. , vbYesNo, 提示)If mg = 6 ThenElse Unload User

15、Form1End IfEnd IfEnd SubPrivate Sub mandButton2_Click()Unload UserForm1End SubPrivate Sub UserForm_Initialize()With Me.ListBo*1.List = ar文本框赋值.ListStyle = 1文本前加选择小方框.MultiSelect = 1设置可多项选择End WithMe.Label1.Caption = Me.Label1.Caption & nmEnd Sub4，多工作表汇总字典、数组Data多表汇总0623.*lsSub dbhz()多表汇总Dim Sht1 As

16、Worksheet, Sht2 As Worksheet, Sht As WorksheetDim d, k, t, Myr&, Arr, *Application.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

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

18、Replace(Mid(.a3, 7), /, -) Myr = .h65536.End(*lUp).Row Arr = .Range(d10:h & Myr) Set d = CreateObject(Scripting.Dictionary) For i = 1 To UBound(Arr) * = Arr(i, 1) If Not d.e*ists(*) Then d.Add *, Arr(i, 5) Else d(*) = d(*) + Arr(i, 5) End If Ne*t k = d.keys t = d.items Set Sht2 = Sheets(nm) Sht2.Act

19、ivate myr2 = a65536.End(*lUp).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

20、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 Then Brrbz(mm, j) = Cells(j / 2 + 34, 11).Value Else Brrbz(mm, j) = Cells(j / 2 + 34, 9).Value End If Ne*t GoTo 100 Else If b2 = The

21、n 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 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, ) n

22、m = Right(Filename, Len(Filename) - aa) 带后缀的E*cel文件名 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 Ne*t Else MsgBo* 该文件夹里没有任何文件 End If

23、End With Sht1.Select a3.Resize(UBound(Brr), 2) = Brr Set myFs = NothingApplication.ScreenUpdating = TrueEnd SubSub pldrsj0707()6387-1-1.htmlReport 2.*ls批量导入指定文件的数据 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 Works

24、heet, sh As Worksheet Application.ScreenUpdating = 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 = *.*ls .SearchSubFolders = True If .E*ec

25、ute(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)nm1=split(mid(filename,instrrev(filename,)+1),.)(0)一句代码代替以下3句aa = InStrRev(Filename, )nm = Right(Filename, Len(Filename) - aa) 带后缀的E*cel文件名nm1 = Le

26、ft(nm, Len(nm) - 4) 去除后缀的E*cel文件名 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(*lUp).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).Resiz

27、e(1, 3).Value Sht1.Cells(nn, 5) = Cells(ii, 6).Value nn = nn + 1 Ne*t ii GoTo 100 Else GoTo 100 End If mc = d65536.End(*lUp).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

28、 = nn + 1 Ne*t ii GoTo 100 Else GoTo 100 End If100: Ne*t sh wb.Close savechanges:=False Set wb = Nothing End If Ne*t Else MsgBo* 该文件夹里没有任何文件 End If End With a1.Select Set myFs = NothingApplication.ScreenUpdating = TrueEnd Subsum.*lsSub pldrsj0724()批量导入指定文件的数据 Dim myFs As FileSearch, myfile, Myr1&, A

29、rr Dim myPath$, Filename$, nm2$ 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(*lUp).Row Arr = Sht1.Range(a3:b & Myr1) Sht1.Range(b3:b & Myr1).ClearContents nm2 = Left(ActiveWorkbook.Name, Le

30、n(ActiveWorkbook.Name) - 4) Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = *.*ls If .E*ecute(SortBy:=msoSortByFileName) 0 Then n = .FoundFiles.Count ReDim myfile(1 To n) As String For i = 1 To n myfile(i)

31、 = .FoundFiles(i) Filename = myfile(i) aa = InStrRev(Filename, ) nm = Right(Filename, Len(Filename) - aa) 带后缀的E*cel文件名 nm1 = Left(nm, Len(nm) - 4) 去除后缀的E*cel文件名 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.Na

32、me = 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 Ne*t j Ne*t sh100: wb.Close savechanges:=False Set wb = Nothing End If Ne*t Else MsgBo* 该文件夹里没有任何文件 End If End With Sht1.Select b3.Resize(UBound(Arr), 1) = Application.Inde*(Arr, 0,

33、 2) Set myFs = NothingApplication.ScreenUpdating = TrueEnd Sub6，多工作表提取指定数据数组e*cel.aa.topzj./viewthread.php?tid=399457&pid=73718&page=1&e*tra=*pid73718Sub fpkf()Application.ScreenUpdating = FalseDim Myr&, Arr, yf, *&, Myr1&, r1Dim Sht As WorksheetMyr = Sheet1.b65536.End(*lUp).RowSheet1.Range(c8:h & M

34、yr).ClearContentsArr = Sheet1.Range(c8:h & Myr)j8.Formula = =rc-9&|&rc-8j8.AutoFill Range(j8:j & Myr)Range(j8:j & Myr) = Range(j8:j & Myr).ValueFor Each Sht In Sheets If Sht.Name Sheet1.Name Then yf = Left(Sht.Name, Len(Sht.Name) - 2) Sht.Activate Myr1 = a65536.End(*lUp).Row - 1 For * = 7 To Myr1 If

35、 Cells(*, 1) Then Set r1 = Sheet1.Range(j:j).Find(Cells(*, 1) & | & Cells(*, 2) If Not r1 Is Nothing Then Arr(r1.Row - 7, yf) = Cells(*, ar) End If End If Ne*t * End IfNe*tSheet1.Activatec8.Resize(UBound(Arr), UBound(Arr, 2) = Arrj:j.ClearApplication.ScreenUpdating = TrueEnd Sub7，多工作簿多工作表查询汇总去重复值字典数

36、组详细记录.*ls3个工作簿需要都翻开Sub *jl()Dim Sht1 As Worksheet, Sht As WorksheetDim wb1 As Workbook, wb2 As Workbook, wb3 As WorkbookDim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, *m$, yl$Application.ScreenUpdating = FalseSet wb1 = ActiveWorkbookSet wb2 = Workbooks(购进)Set wb3 = Workbooks(配料)wb2.ActivateMyr2 = a65536.End

37、(*lUp).RowArr2 = Range(a2:d & Myr2)wb3.ActivateFor i = 1 To UBound(Arr2) wb3.Activate *m = Arr2(i, 2) For Each Sht In Sheets If Sht.Name = *m Then Sht.Activate Myr = a65536.End(*lUp).Row Arr = Range(a1:b & Myr) For j = 1 To UBound(Arr) yl = Arr(j, 1) wb1.Activate For Each Sht1 In Sheets If Sht1.Name = yl Then Sht1.Activate