Dim s, Myr&
Application.ScreenUpdating = False Set Twb = ThisWorkbook
Cells.ClearContents '清除当前表的内容 With Application.FileSearch '查找
.LookIn = Twb.Path '范围为此目录下 .Filename = \查找所有的xls文件
.Execute msoSortByFileName '执行查找过程，并且将查询结果按文件名排序
For Each s In .FoundFiles '在每一个查找到的结果里 If s <> Twb.FullName Then '假如它不是当前工作簿 Set Wb = Workbooks.Open(s) '打开它
Set rng = Range(\设置变量rng为最后一行的下一行
Wb.Sheets(1).UsedRange.Copy rng '复制新打开的工作簿的第一个工作表的已用区域到rng
Cells(rng.Row, 10) = Wb.Name
Wb.Close False ' 不保存就关闭这个打开的工作簿 End If Next End With
Application.ScreenUpdating = True End Sub
16，汇总至多工作簿（Move/SaveAs）
'http://club.excelhome.net/thread-598830-1-1.html Sub fb()
Dim i&, Myr&, Myc%, Arr, col%, bt, n&, pa$, nm$ Dim Sht1 As Worksheet, Sht As Worksheet Application.ScreenUpdating = False pa = ThisWorkbook.Path Set Sht1 = ActiveSheet
Myr = [a65536].End(xlUp).Row Myc = [iv2].End(xlToLeft).Column Arr = Range(\
bt = Array(\品牌\类\零\厂址\编号\For col = 11 To UBound(Arr, 2)
Sheets.Add after:=Sheets(Sheets.Count)
n = 2
Set Sht = ActiveSheet
[a1] = Arr(1, col) & \alue [a2].Resize(1, 5) = bt Cells(n, 6) = Arr(1, col) For i = 2 To UBound(Arr) If Arr(i, col) <> \ n = n + 1
Cells(n, 1) = Arr(i, 1) Cells(n, 2) = Arr(i, 7) Cells(n, 3) = Arr(i, 8) Cells(n, 4) = Arr(i, 9) Cells(n, 5) = Arr(i, 10) Cells(n, 6) = Arr(i, col) End If Next
Range(\Cells.Select
With Selection.Font .Name = \宋体\ .Bold = True .Size = 16 End With
With Selection
.HorizontalAlignment = xlCenter End With
Range(\
nm = pa & \Sht.Move
ActiveWorkbook.SaveAs Filename:=nm ActiveWorkbook.Close Next
Application.ScreenUpdating = True End Sub
17，2007版用Dir至多工作簿子文件夹 by:青城
‘http://www.excelpx.com/dispbbs.asp?boardid=5&replyid=1760169&id=108832&page=1&skin=0&Star=1
Sub main() Dim fp As String fp = \
Call searfile(fp, \
End Sub
Sub searfile(fp As String, fkey As String)
Dim arr1() As String, i1 As Integer, i2 As Integer,fm If Right(fp, 1) <> \
If Len(fkey) < 1 Then fkey = \文件类型省略则仅搜索.xls文件 fm = Dir(fp, vbDirectory) Do While fm <> \
If fm <> \
If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then i1 = i1 + 1
ReDim Preserve arr1(1 To i1) arr1(i1) = fp & fm End If
If Right(fm, 4) = fkey Then
Range(\'将文件路径及名称写入当前工作表的A列
End If End If fm = Dir Loop
For i2 = 1 To i1
Call searfile(arr1(i2), \Next End Sub
18，用Dir提取多工作簿数据 （ADO）
‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=135431&star=1#1862014 ‘发料一.xls 需要先引用Ado 2.7
Sub 多工作簿提取数据() '2010-7-21
Dim sh As String, nm$, m%, Myr&, i&, n&, nm1$ Dim sql$, conn As ADODB.Connection Dim Sht As Worksheet Set Sht = ActiveSheet
Sht.[a3:m1000].ClearContents nm1 = ThisWorkbook.Name
sh = Dir(ThisWorkbook.Path & \ While Not Len(sh) = 0 And sh <> nm1 Set conn = New ADODB.Connection
nm = ThisWorkbook.Path & \ With conn
.Provider = \
.ConnectionString = \Properties='Excel 8.0;hdr=yes;imex=1;';data source=\
.Open End With
sql = \生产领用明细表$a2:m1000] \ n = Sht.[a65536].End(xlUp).Row + 1
Sht.Cells(n, 1).CopyFromRecordset conn.Execute(sql) sh = Dir conn.Close Wend
Set conn = Nothing End Sub
19，多工作簿提取指定数据（FileSystemObject）by:一念
‘http://club.excelhome.net/thread-617951-1-1.html Sub GetData()
Dim Fso As Object, Fld Dim rng As Range, Arr
Set Fso = CreateObject(\
For Each Fld In Fso.getfolder(ThisWorkbook.Path & \
Arr = GetObject(Fld.Path & \备用整理.xls\明细\ GetObject(Fld.Path & \备用整理.xls\
Set rng = Rows(1).Find(Fld.Name, , , 1)(3) ‘第3行 rng.Resize(UBound(Arr), 2) = Arr Next End Sub
‘模版0827.xls
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=911279&page=1#pid6248314 Sub GetData()
Dim Fso As Object, Fld, nm, col%, Arr, Myc%, r%, Arr1() Dim wb As Workbook, Sht As Worksheet Application.ScreenUpdating = False
Set Fso = CreateObject(\
Set Fld = Fso.getfolder(ThisWorkbook.Path & \ For Each nm In Fld.Files ‘先找出应该文件夹里面的文件 r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = nm.Name Next
For i = 1 To r
Set wb = Workbooks.Add Set Sht = wb.Worksheets(1)
For Each Fld In Fso.getfolder(ThisWorkbook.Path & \ Arr = GetObject(Fld.Path & \Arr1(i)).Sheets(\
GetObject(Fld.Path & \ Myc = [iv1].End(xlToLeft).Column
If Myc <> 1 Then col = Myc + 1 Else col = 1
Sht.Cells(1, col).Resize(UBound(Arr), UBound(Arr, 2)) = Arr Next
wb.SaveAs ThisWorkbook.Path & \ wb.Close Next
Application.ScreenUpdating = True End Sub
&
20，2007版FSO代替FileSearch的方法
‘修改技巧202 VBA技巧精粹（FSO）递归进入子文件夹，获得指定后缀文件 Dim Arr1(), r%, strTmp As String
Function GetFileFolderList(ObjFolder) As String Dim SubFolders, SubFolder, hz$ Dim Files, File hz = \‘指定后缀 Set Files = ObjFolder.Files If Files.Count <> 0 Then For Each File In Files
If Right(File, 3) = hz Then r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = File End If Next End If
Set SubFolders = ObjFolder.SubFolders If SubFolders.Count <> 0 Then
For Each SubFolder In SubFolders