Excel VBA_多工作簿多工作表汇总实例集锦(2)

End With

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

4，多工作表汇总（字典、数组）

‘http://club.excelhome.net/viewthread.php?tid=450709&pid=2928374&page=1&extra=page=1

‘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(\

For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字 If InStr(Sht.Name, \ 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, \

nm = Replace(Mid(.[a3], 7), \ Myr = .[h65536].End(xlUp).Row Arr = .Range(\

Set d = CreateObject(\ 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(\

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

‘http://club.excelhome.net/thread-759188-1-1.html 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 = \

.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, \ 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 = \班子\ 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] = \ 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 = \班子\

[a2].Resize(mm, 19) = Brrbz Else

[a2].Resize(mm, 23) = Brrgr End If [a1].Select

Set myFs = Nothing End Sub

‘2011-7-15

‘http://club.excelhome.net/viewthread.php?tid=741341&pid=5036524&page=1&extra= 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 = \

.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(\ 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()

'http://club.excelhome.net/thread-456387-1-1.html 'Report 2.xls

'批量导入指定文件的数据

Dim myFs As FileSearch, myfile

Dim myPath As String, Filename$, ma&, mc&

带后缀

百度搜索“77cn”或“免费范文网”即可找到本站免费阅读全部范文。收藏本站方便下次阅读，免费范文网，提供经典小说综合文库Excel VBA_多工作簿多工作表汇总实例集锦(2)在线全文阅读。