Question

我正在使用此代码列出Excel中的文件夹和子文件夹中的所有文件。这段代码工作正常。我想为每个子文件夹留一个空白行。目前它在所有行中连续列出。请帮忙。

Sub HyperlinkDirectory()

Dim fPath As String
Dim fType As String
Dim fname As String
Dim NR As Long
Dim AddLinks As Boolean

'Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
         .InitialFileName = "C:\2009\"
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

'Types of files
    fType = Application.InputBox("What kind of files? Type the file extension to collect" _
            & vbLf & vbLf & "(Example:  pdf, doc, txt, xls, *)", "File Type", "pdf", Type:=2)
    If fType = "False" Then Exit Sub

'Option to create hyperlinks
    AddLinks = MsgBox("Add hyperlinks to the file listing?", vbYesNo) = vbYes

'Create report
    Application.ScreenUpdating = False
    NR = 5
    With Sheets("Sheet1")
        .Range("A:C").Clear
        .[A1] = "Directory"
        .[B1] = fPath
        .[A2] = "File type"
        .[B2] = fType
        .[A4] = "File"
        .[B4] = "Modified"

        Call FindFilesAndAddLinks(fPath, fType, NR, AddLinks)




        .Range("A:B").Columns.AutoFit
    End With

    Application.ScreenUpdating = True
End Sub

Private Sub FindFilesAndAddLinks(fPath As String, fType As String, ByRef NR As Long, AddLinks As Boolean)
Dim fname As String
Dim oFS As New FileSystemObject
Dim oDir


    'Files under current dir
    fname = Dir(fPath & "*." & fType)
    With Sheets("Sheet1")

        Do While Len(fname) > 0
          'filename
            .Range("A" & NR) = fname
          'modified
            .Range("B" & NR) = FileDateTime(fPath & fname)
          'hyperlink
            .Range("A" & NR).Select
            If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
                Address:=fPath & fname, _
                TextToDisplay:=fPath & fname
          'set for next entry
            NR = NR + 1
            fname = Dir
        Loop

        'Files under sub dir
        Set oDir = oFS.GetFolder(fPath)
        For Each oSub In oDir.SubFolders
            Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
        Next oSub
    End With


End Sub

Answer 1

下面更改的FindFilesAndAddLinks将创建以下格式：

FolderRoot\Folder1\Subfolder1
FolderRoot\Folder1\Subfolder1\FirstFileFound
FolderRoot\Folder1\Subfolder1\SecondFileFound

FolderRoot\Folder2\Subfolder2
FolderRoot\Folder2\Subfolder2\FirstFileFound
FolderRoot\Folder2\Subfolder2\SecondFileFound
...

新宏：

Private Sub FindFilesAndAddLinks(fPath As String, fType As String, ByRef NR As Long, AddLinks As Boolean)
Dim fname As String
Dim oFS As New FileSystemObject
Dim oDir

'Files under current dir
fname = Dir(fPath & "*." & fType)
With Sheets("Sheet1")

    'Write folder name
    .Range("A" & NR) = fPath
    NR = NR + 1

    Do While Len(fname) > 0
      'filename
        If .Range("A" & NR) <> "" Then Debug.Print "Overwriting " & NR
        .Range("A" & NR) = fname
      'modified
        .Range("B" & NR) = FileDateTime(fPath & fname)
      'hyperlink
        .Range("A" & NR).Select
        If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
            Address:=fPath & fname, _
            TextToDisplay:=fPath & fname
      'set for next entry
        NR = NR + 1
        fname = Dir
    Loop

    'Files under sub dir
    Set oDir = oFS.GetFolder(fPath)
    For Each oSub In oDir.SubFolders
        NR = NR + 1
        Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
    Next oSub
End With

End Sub

Answer 2

您好我不确定对于子文件夹的Blank Row是什么意思。但我想如果你在子文件夹循环中添加NR = NR+1，它应该没问题。

 'Files under sub dir
     Set oDir = oFS.GetFolder(fPath)
     For Each oSub In oDir.SubFolders
          NR = NR + 1
          Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
     Next oSub

目录中的文件夹子文件夹中的文件列表

2 个答案: