Excel-VBA-多工作簿多工作表汇总实例集锦.doc

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
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 Sub

Sub sumdemo()
Dim arr As Variant
arr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6")
With Worksheets("汇总").Range("A1")
.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) = "'[" & bk.Name & "]" & sht.Name & "'!" & _
sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
End If
Next
Worksheets(1).Range("A1").Consolidate _
RangeArray, xlSum, True, True
End Sub

3，多工作簿汇总（FileSearch）
‘
‘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 = "*.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(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).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 = "*.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(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.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, col1).Resize(UBound(arr), 1) = arr
Next j
100: 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 <> "" Then
s = Left(s, Len(s) - 1)
ar1 = Split(s, ",")
MsgBox "你选择了 " & s
Unload UserForm1
Else
mg = MsgBox("你没有选择任何工作表！需要重新选择吗？ ", vbYesNo, "提示")
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 ‘设置可多选

End With
Me.Label1.Caption = Me.Label1.Caption & nm
End Sub

4，多工作表汇总（字典、数组）
‘
‘Data多表汇总0623.xls
Sub dbhz()
'多表汇总
Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As Worksheet
Dim d, k, t, Myr&, Arr, x
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字
If InStr(ShtName, "-") > 0 Then Sht.Delete: GoTo 100
nm = Mid(Sht.[a3], 7)
d(nm) = ""
100:
Next Sht
Application.DisplayAlerts = True
k = d.keys
For i = 0 To UBound(k)
Sheets.Add after:=Sheets(Sheets.Count)
Set Sht1 = ActiveSheet
Sht1.Name = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/不能用作表名的）改为”-“
Next i
Erase k
Set d = Nothing
For 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 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(xlUp).Row + 1
If myr2 < 9 Then
Cells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")
Cells(10, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)
Cells(10, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t)
Else
Cells(myr2, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)
Cells(myr2, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t)
End If
Erase k
Erase t
Set d = Nothing
End If
End With
Next Sht
Application.ScreenUpdating = True
End Sub

5，多工作簿提取指定数据（FileSearch）
‘2011-8-31
‘
Sub GetData()
Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)
Dim myFs As FileSearch, myfile
Dim myPath As String, Filename$, wbnm$
Dim i&, n&, mm&, aa$, nm1$, j&
Dim Sht1 As Worksheet, sh As Worksheet, wb1 As Workbook
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
wbnm = Left(wb1.Name, Len(wb1.Name) - 4)
Set Sht1 = ActiveSheet

Sht1.[a2:w200] = ""
aa = Left(Sht1.Name, 2)
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path & "\"
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)
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 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(mm, 1) = [b2].Value
Brrgr(mm, 2) = [e38].Value
Brrgr(mm, 3) = [i38].Value
For j = 4 To 18 Step 2
If j < 12 Then
Brrgr(mm, j) = Cells(j / 2 + 38, 8).Value

Else
Brrgr(mm, j) = Cells(j / 2 + 38, 7).Value
End If
Next
For j = 20 To 23
Brrgr(mm, j) = Cells(j + 28, 8).Value
Next
End If
End If
50:
Next
100:
wb.Close savechanges:=False
Set wb = Nothing
200:
Next
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
If aa = "班子" Then
[a2].Resize(mm, 19) = Brrbz
Else
[a2].Resize(mm, 23) = Brrgr
End If
[a1].Select
Set myFs = Nothing
End Sub

‘2011-7-15
‘
Sub pldrsj()
'批量导入指定文件的数据
    Dim myFs As FileSearch, myfile, Brr
    Dim myPath$, Filename$, nm2$
    Dim i&, j&, n&, aa$, nm$
    Dim Sht1 As Worksheet, sh As Worksheet
    Application.ScreenUpdating = False
    Set Sht1 = ActiveSheet
    Sht1.Cells.ClearContents
    nm2 = ActiveWorkbook.Name
    Set myFs = Application.FileSearch
    myPath = ThisWorkbook.Path
    With myFs
        .NewSearch
        .LookIn = myPath
        .FileType = msoFileTypeNoteItem
        .Filename = "*.xls"
        .SearchSubFolders = True
        If .Execute(SortBy:=msoSortByFileName) > 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(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("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].Resize(UBound(Brr), 2) = Brr
    Set myFs = Nothing
Application.ScreenUpdating = True
End Sub

Sub 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.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 = "*.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)
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文件名
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 =