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

来源：互联网发布：ora27102 windows 编辑：程序博客网时间：2024/05/16 19:25
从网上找了一些信息，自己修改了一下
方式很直白，先把所有的目录找了出来，然后一个个目录来处理。
虽然与我习惯使用迭代的的方式有所差别，但也很好。
后面的函数是原始的，没有改动，主函数自己重新写过了。
文件下载
 '主函数     Sub ListFilesInCurFolder() '//函数实例    Cells(1, 1) = "序号"    Cells(1, 2) = "文件名称"    Cells(1, 3) = "文件类型"     Cells(1, 4) = "路径"Dim strCurfileNameDim CurRowCurRow = 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
文件下载
0 0