ExcelVBA多工作簿多工作表汇总情况实例集锦.doc
82页
word1，多工作表汇总〔Consolidate〕‘.excelpx./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("汇总") ReDim RangeArray(1 To WbCount - 1) 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", "二月!R1C1: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 ReDim RangeArray(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 _ RangeArray, xlSum, True, TrueEnd Sub3，多工作簿汇总〔FileSearch〕‘ pldrwb0531()'导入指定文件的数据 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 With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = "*.xls" If .Execute(SortBy:=msoSortByFileName) > 0 Then 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(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)) 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‘根据上例增加了在一个工作簿中可选择多个工作表进展汇总，运用了文本框多项选择功能Public ar, ar1, nm$Sub pldrwb0531()'导入指定文件的数据〔默认工作表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 Sht1 = ActiveSheet With myFs .NewSearch .LookIn = myPath .FileType = msoFileTypeNoteItem .Filename = "*.xls" If .Execute(SortBy:=msoSortByFileName) > 0 Then 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(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, ",") For j = 0 To UBound(ar1) If Err.Number = 9 Then GoTo 100 Set sh = wb.Sheets(ar1(j)) m = sh.[a65536].End(xlUp).Row arr = Range(Cells(3, 3), Cells(m, 3)) 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(UB。
