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&
带后缀