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

小鱼儿 2022-08-07 00:23 91阅读 0赞

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

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

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

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

[文件下载][Link 1]

![SouthEast][]

'主函数
        
     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

[文件下载][Link 1]

[Link 1]: http://download.csdn.net/detail/haoyujie/8442015
[SouthEast]: /images/20220805/be09aacd2540498dbd89eb68306cff96.png