excel宏：列出一个目录下所有文件，并做也超链接



从网上找了一些信息，自己修改了一下

方式很直白，先把所有的目录找了出来，然后一个个目录来处理。

虽然与我习惯使用迭代的的方式有所差别，但也很好。

后面的函数是原始的，没有改动，主函数自己重新写过了。

文件下载

 '主函数
    
 Sub ListFilesInCurFolder() '//函数实例

    Cells(1, 1) = "序号"
    Cells(1, 2) = "文件名称"
    Cells(1, 3) = "文件类型"
     Cells(1, 4) = "路径"


Dim strCurfileName
Dim CurRow
CurRow = 2


    arr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name)
    For I = 0 To UBound(arr)
       ' MsgBox arr(I)
        'Set WB = Workbooks.Open(arr(I))
        '你的代码
        'WB.Close False
        
        
            'lj = "E:\ToolDev\ExcelTools\ListFileInFolder\test"
    

    
    Dim wj As String
    
    'wj = Dir(lj & "\*.*")
    
 
        Dim idx As Integer
        idx = InStrRev(arr(I), "\")
        If idx >= 0 Then
            strCurfileName = Mid(arr(I), idx + 1, Len(arr(I)))
        Else
            strCurfileName = arr(I)
        End If

    
        'Cells(([A65536].End(xlUp).Row + 1), 1) = [A65536].End(xlUp).Row
       ' Cells(([C65536].End(xlUp).Row + 1), 3).FormulaR1C1 = "=MID(RC[-1],FIND(""."",RC[-1])+1,LEN(RC[-1]) - FIND(""."",RC[-1]))"
       ' Cells(([B65536].End(xlUp).Row + 1), 2).Select
      Cells(CurRow, 1) = CurRow - 1

    Cells(CurRow, 3).FormulaR1C1 = "=MID(RC[-1],FIND(""."",RC[-1])+1,LEN(RC[-1]) - FIND(""."",RC[-1]))"
        
            Cells(CurRow, 2).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=arr(I), TextToDisplay:=strCurfileName
       
            '相对路径，但证明无用，绝对路径，在excel中，会被自动转为相对路径
            'Cells(CurRow, 4).Select
            'Dim RefPath
            'RefPath = Mid(arr(I), Len(ThisWorkbook.Path) + 2, Len(arr(I)))
            'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=RefPath, TextToDisplay:=strCurfileName
        
       '''''''''''''
       Cells(CurRow, 4).Select
       Dim CurFolder
      CurFolder = Left(arr(I), idx)
      
      CurFolder = Mid(CurFolder, Len(ThisWorkbook.Path) + 2, Len(CurFolder))
      
      Cells(CurRow, 4) = CurFolder
      
        CurRow = CurRow + 1
    Next
    
    
        Columns("A:C").Select
        Columns("A:C").EntireColumn.AutoFit
    End Sub
    '****************************************************************
    '功能：    查找指定文件夹含子文件夹内所有文件名（含路径）
    '函数名：  FileAllArr
    '参数1：   Filename    需查找的文件夹名 不含最后的"\"
    '参数2：   FileFilter  需要过滤的文件名，可省略，默认为：[*.*]
    '参数3：   Liwai       剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
    '返回值：  一个字符型的数组
    '使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)

    Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "") As String()
        Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
        Set Did = CreateObject("Scripting.Dictionary")
        Dic.Add (Filename & "\"), ""
        I = 0
        Do While I < Dic.Count
            Ke = Dic.keys   '开始遍历字典
            MyName = Dir(Ke(I), vbDirectory)    '查找目录
            Do While MyName <> ""
                If MyName <> "." And MyName <> ".." Then
                    If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                        Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                    End If
                End If
                MyName = Dir    '继续遍历寻找
            Loop
            I = I + 1
        Loop
      
    I = 0
    Dim arrx() As String
        For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
            MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
            Do While MyFileName <> ""
               If MyFileName <> Liwai Then '排除例外文件
                  ReDim Preserve arrx(I)
                  arrx(I) = Ke & MyFileName
                  I = I + 1
               End If
                MyFileName = Dir
            Loop
        Next
        FileAllArr = arrx
    End Function
    '****************************************************************




    'Sub g1()

     '   Dim fso, fl, m&
    '    Set fso = CreateObject("Scripting.FileSystemObject")
    '    For Each fl In fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & "\").Files
   '        m = m + 1
   '        Cells(m, 2) = fl.Name
   '     Next

 '   End Sub

文件下载