自己用的一段用于生成文件目录的Excel宏
转载：http://blog.163.com/weizy@126/blog/static/8450240201051032057311/
'Special Announcement'CreateCatalog'V1.0'Powered by Kenneth'This program is free and Open Source'All copyright reserved.'Edition update list'V1.0 All basic functions available,'creates a number of worksheets according to the first level subfolder names'creates all files catalog of each first level subfolder worksheet'create relative hyperlinks between worksheets and to every file.Sub CreateCatalog()'变量声明'Program explanation'This is a VBA program which only can be used under Microsoft Excel environment'The program is used to create a catalog of all subfolders and files in a specified folder (same as this program position)Dim MyPath As String, MyFileName As String '路径名和文件名Dim TempCounterI As Integer, TempCounterJ As Integer '计数变量Dim TempStr As String '临时变量用于根据目录表生成不同工作表时中转Dim TempStr2 As String '临时变量用于生成超链接Dim ws As Worksheet'临时关闭屏幕更新和显示报警Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume Next'设置搜索路径MyPath = ThisWorkbook.PathTempCounterI = 1TempCounterJ = 1'开始搜索路径 MyFileName = Dir(MyPath & "\*.*", 16) '第一次使用Dir函数时必须带路径，之后不带路径，自动返回该目录中下一个文件值。参数16见函数帮助'清除原有工作簿中内容For Each Worksheet In ThisWorkbook.Worksheets If Worksheets.Count > 1 Then Worksheets(2).Delete End IfNextThisWorkbook.Worksheets(1).Name = "目录" '更改第一个表名称 '取根目录列表放在第一个表中Do While MyFileName <> "" '开始循环 If (MyFileName <> ".") And (MyFileName <> "..") And (GetAttr(MyPath & "" & MyFileName) And vbDirectory) Then '如果为目录则存在B列 Range("B" & TempCounterI) = MyFileName TempCounterI = TempCounterI + 1 End If MyFileName = Dir(, 16) '继续搜索下一个文件Loop'根据根目录列表生成不同的工作表TempStr = ThisWorkbook.Worksheets(1).Cells(TempCounterJ, 2)Do While TempStr <> ""For Each ws In ThisWorkbook.Worksheets If LCase(ws.Name) = LCase(TempStr) Then MsgBox ("Error") '如果有重名的表则过程终止 Exit Sub End IfNextSet ws = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count)) '生成新表ws.Name = ThisWorkbook.Worksheets(1).Cells(TempCounterJ, 2) '新表名称为根目录下第一层子目录的名称。为了避免生成太多表，本程序仅针对第一层子目录生成不同的工作表。Set ws = Nothing'调用子程序生成每张子表的内容，并生成目录到子表的超链接Call Sublist(MyPath, TempStr) '子过程内容见下面Str2 = ThisWorkbook.Sheets(TempCounterJ + 1).Name '生成到每个文件的超链接ThisWorkbook.Sheets(1).Range("A" & TempCounterJ).hyperlinks.Add Anchor:=ThisWorkbook.Sheets(1).Range("A" & TempCounterJ), Address:="", SubAddress:=Str2 & "!A1", TextToDisplay:="打开"TempCounterJ = TempCounterJ + 1TempStr = ThisWorkbook.Worksheets(1).Cells(TempCounterJ, 2)Loop'补充内容，将根目录下的文件也列出来ThisWorkbook.Sheets(1).Cells(TempCounterI, 1).EntireRow.InsertTempCounterI = TempCounterI + 1ThisWorkbook.Sheets(1).Cells(TempCounterI, 1).EntireRow.InsertThisWorkbook.Sheets(1).Range("A" & TempCounterI) = "以下为根目录下文件列表"TempCounterI = TempCounterI + 1MyPath = ThisWorkbook.PathMyFileName = Dir(MyPath & "\*.*")Do While MyFileName <> "" ' And TempCounterI <= 1000 If MyFileName <> "目录整理.xls" Then ThisWorkbook.Sheets(1).Range("B" & TempCounterI) = MyFileName Str2 = ThisWorkbook.Sheets(1).Name ThisWorkbook.Sheets(1).Range("A" & TempCounterI).hyperlinks.Add Anchor:=ThisWorkbook.Sheets(1).Range("A" & TempCounterI), Address:=MyPath & "" & MyFileName, SubAddress:="", TextToDisplay:="打开" TempCounterI = TempCounterI + 1 End If MyFileName = Dir()Loop'打开屏幕更新和显示报警Application.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub'子过程，用于生成每个子目录下所有文件及其下所有子目录内文件的清单和超链接Sub Sublist(MyPath As String, Myname As String) Dim Str1 As String '用于存储目录的临时变量 Dim Str2 As String '用于存储文件名的临时变量 Dim Str3 As String '用于生成超链接的临时变量 Dim i As Integer '计数用临时变量 Dim j As Integer '计数用临时变量 Dim m As Integer '计数用临时变量 ThisWorkbook.Sheets(Myname).Range("C1") = MyPath & "" & Myname '生成当前文件路径 i = 1 j = 1 m = 0 '开始循环 Do Str1 = ThisWorkbook.Sheets(Myname).Range("C" & i) Str2 = Dir(Str1 & "\*.*", 16) '从当前表C列取临时保存的路径值，在dir函数中，每个路径下只有第一次需要用路径值 Do While Str2 <> "" '循环，依次判断文件类型 If (Str2 <> ".") And (Str2 <> "..") Then If (GetAttr(Str1 & "" & Str2) And vbDirectory) Then '如果是目录则暂存在C列 j = j + 1 ThisWorkbook.Sheets(Myname).Range("C" & j) = Str1 & "" & Str2 Else m = m + 1 ThisWorkbook.Sheets(Myname).Range("B" & m) = Str2 '如果不是目录则在B列依次列出 Range("A" & m).hyperlinks.Add Anchor:=Range("A" & m), Address:=Str1 & "" & Str2, SubAddress:="", TextToDisplay:="打开" '从A列生成到B列文件的超链接 End If End If Str2 = Dir(, 16) '继续搜索下一个文件，直到为空 Loop i = i + 1 'i+1，开始取下一个子目录的路径，直到所有的子目录被遍历 Loop While ThisWorkbook.Sheets(Myname).Range("C" & i).Value <> "" ThisWorkbook.Sheets(Myname).Columns(3).Delete '删除临时保存路径的第C列 ThisWorkbook.Sheets(Myname).Cells(1, 1).EntireRow.Insert '插入一行 Str3 = ThisWorkbook.Worksheets(1).Name '在插入的第一行生成到第一个表的超链接 Range("A1").hyperlinks.Add Anchor:=Range("A1"), Address:="", SubAddress:=Str3 & "!A1", TextToDisplay:="返回" End Sub