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

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

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