请问大神,怎么获取某目录下全部孙文件夹名呢?

yangge523

我想做个程序,获取某路径下全部孙文件夹名,之后每次打开都自动更新,如果有新的文件夹名则在最下面单元格添加,查了好久了,都没查到方法,求大神帮忙

小花鹿

搜索遍历子文件夹                                                                                                      

carlostevez1984

Option Explicit

Private Sub 提取文件信息并添加超链接_Click()

Rem 2019-4-19制作，2019－4－20再整理
Rem 作用：遍历文件夹（包括子文件夹），提取文件名等信息，并在文件名上添加超链接
Rem 代码来源 http://club.excelhome.net/thread-1391369-3-1.html
Rem 代码来源 http://club.excelhome.net/thread-1472524-1-1.html

    Dim pth$, arr
    Dim i As Long
    Dim r As Long
   
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = -1 Then
                pth = .SelectedItems(1)
            Else
                MsgBox "您没有选择任何文件夹！", vbCritical: Exit Sub
            End If
        End With
        
    ReDim arr(1 To 6, 1 To 1)
        arr(1, 1) = "文件名称"
        arr(2, 1) = "文件位置"
        arr(3, 1) = "创建日期"
        arr(4, 1) = "修改日期"
        arr(5, 1) = "文件类型"
        arr(6, 1) = "文件大小"
        Getfd pth, arr
    arr = Application.WorksheetFunction.Transpose(arr)
     
Rem 在A列添加超链接
    For i = 2 To UBound(arr)
        arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 1) & """)"
    Next i
   
    Application.ScreenUpdating = False
        With ActiveSheet
            .UsedRange.CLEAR
            .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            r = .Range("a" & Rows.Count).End(3).Row
            .Range("a1:f" & r).Borders.LineStyle = xlContinuous
            .Range("a1:f" & r).Borders.Weight = xlThin
        End With
    Application.ScreenUpdating = True

    Call 生成新文件                                                                     '2019-4-20
     
    MsgBox "文件已全部获取！点『确定』键结束，请在本文件路径下查找“目录表+现在日期、时间”工作簿！"
   
    ThisWorkbook.Saved = True
    Application.Quit
   
End Sub

Sub Getfd(ByVal pth As String, arr)
    Dim fso As Object, f, fd, ff
    Dim u
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.GetFolder(pth)
        For Each f In ff.Files
            ReDim Preserve arr(1 To 6, 1 To UBound(arr, 2) + 1)
            u = UBound(arr, 2)
            arr(1, u) = f.Name
            arr(2, u) = f
            arr(3, u) = f.DateCreated
            arr(4, u) = f.DateLastModified
    '        arr(5, u) = f.Type
Rem 将文件类型修改为文件后缀名
           arr(5, u) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
           arr(6, u) = Format(f.Size / 1048576, "0.00MB")
        Next
    For Each fd In ff.SubFolders: Getfd fd, arr: Next
End Sub

Sub 生成新文件()
Rem 目的：生成的新文件不包含代码和控件
Rem 代码来源 http://club.excelhome.net/forum.php/tree/thread-1231763-1-1.html
Rem 2019-4-20 12:00

Dim a As Shape
    Application.DisplayAlerts = False
        For Each a In ActiveSheet.Shapes
            a.Delete
        Next
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.path & "\目录表  " & Format(Now(), "yyyy-mm-dd  hh：mm：ss"), FileFormat:=51
    Application.DisplayAlerts = True
            
End Sub

yangge523

carlostevez1984 发表于 2020-1-15 19:23
Option Explicit

Private Sub 提取文件信息并添加超链接_Click()

并不能解决问题