1，多工作表汇总（Consolidate）
‘http://www.excelpx.com/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 Each sht In Sheets
If sht.Name <> \汇总\ i = i + 1
RangeArray(i) = \
sht.Range(\ End If Next
bk.Range(\ [a1].Value = \姓名\ End Sub
Sub sumdemo() Dim arr As Variant
arr = Array(\一月!R1C1:R8C5\二月!R1C1:R5C4\三月!R1C1:R9C6\ With Worksheets(\汇总\ .Consolidate arr, xlSum, True, True .Value = \姓名\ End With End Sub
2，多工作簿汇总（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 - 1)
For Each bk In Workbooks '在所有工作簿中循环
If Not bk Is ThisWorkbook Then '非代码所在工作簿
Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表 i = i + 1
RangeArray(i) = \ sht.Range(\ End If Next
Worksheets(1).Range(\
RangeArray, xlSum, True, True End Sub
3，多工作簿汇总（FileSearch）
‘http://club.excelhome.net/thread-442007-1-1.html### ‘help\\汇总表.xls Sub 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 = False Set Sht1 = ActiveSheet
Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem .Filename = \
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(Filename) - aa) nm1 = Left(nm, Len(nm) - 4) If nm1 <> \汇总表\
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).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 = Nothing
Application.ScreenUpdating = True End Sub
‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能 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 = False On Error Resume Next Set Sht1 = ActiveSheet
Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem .Filename = \
If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count \ + 2, col1))
100: 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 <> \汇总表\
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.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) & ‘显示引用的工作簿工作表及单元格地址
Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) ‘Cells(3, col1).Resize(UBound(arr), 1) = arr Next j
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 = Nothing
Application.ScreenUpdating = True End Sub
Private Sub CommandButton1_Click() For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then s = s & ListBox1.List(i) & \ End If Next i
If s <> \
s = Left(s, Len(s) - 1) ar1 = Split(s, \
MsgBox \你选择了 \Unload UserForm1 Else
mg = MsgBox(\你没有选择任何工作表！需要重新选择吗？If mg = 6 Then Else
Unload UserForm1 End If End If End Sub
Private Sub CommandButton2_Click() Unload UserForm1
End Sub
Private Sub UserForm_Initialize() With Me.ListBox1
.List = ar ‘文本框赋值
.ListStyle = 1 ‘文本前加选择小方框 .MultiSelect = 1 ‘设置可多选
\提示\