自己用的一段用于生成文件目录的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 = False
Application.DisplayAlerts = False
On Error Resume Next

'设置搜索路径
MyPath = ThisWorkbook.Path
TempCounterI = 1
TempCounterJ = 1
'开始搜索路径
 MyFileName = Dir(MyPath & "\*.*", 16) '第一次使用Dir函数时必须带路径，之后不带路径，自动返回该目录中下一个文件值。参数16见函数帮助

'清除原有工作簿中内容
For Each Worksheet In ThisWorkbook.Worksheets
    If Worksheets.Count > 1 Then
        Worksheets(2).Delete
    End If
Next
ThisWorkbook.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 If
Next

Set 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 + 1
TempStr = ThisWorkbook.Worksheets(1).Cells(TempCounterJ, 2)
Loop

'补充内容，将根目录下的文件也列出来
ThisWorkbook.Sheets(1).Cells(TempCounterI, 1).EntireRow.Insert
TempCounterI = TempCounterI + 1
ThisWorkbook.Sheets(1).Cells(TempCounterI, 1).EntireRow.Insert
ThisWorkbook.Sheets(1).Range("A" & TempCounterI) = "以下为根目录下文件列表"
TempCounterI = TempCounterI + 1

MyPath = ThisWorkbook.Path
MyFileName = 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 = True
Application.ScreenUpdating = True
End 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

执行“工具→宏→录制新宏”命令（如图），按“保存在”右侧的下拉按钮，选中“个人宏工作簿”选项后，“确定”进入“宏”录制状态；不需要进行任何操作，直接单击随后展开的“宏”工具条中的“停止录制”按钮，软件会自动生成一个隐藏的“个人宏工作簿”。以后想在“个人宏工作簿”中编辑宏时，就不需要再进行此步操作了。


执行“工具→宏→VisualBasic编辑器”命令（或直接按“Alt+F11”），进入VBA编辑状态。在左侧“工程资源管理器”中，展开 “VBAProject(PERSONAL.XLSB)”选项（这就是“个人宏工作簿”），双击其中的“模块1”，然后用上述代码替换右侧编辑区中的原有代码.

输入完成后，关闭VBA编辑窗口返回到Excel编辑状态。

把EXCEL放到要生成目录的文件夹下，运行宏就会在EXCEL中生成。