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

我正在使用此代码列出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

来源

2017-07-14 ayyappan km

的变化下面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

来源

2017-07-14 09:23:56 CLR

CLR非常感谢你，你的代码工作正常，但我正在'目前目录下的文件 'fname = Dir（fPath＆“*。”＆fType） “和”对于oDir.SubFolders中的每个oSub“ –

您是否正在使用添加文件夹名称的最新版本？ – CLR

你的新代码工作正常。现在它显示的文件夹名称非常感谢你............. –

嗨，我不知道你是什么意思与空白行的子文件夹。但我想如果你在子文件夹循环中添加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

来源

2017-07-14 08:56:14 Moosli

我的意思是，如果在目录中10个个子文件夹，我想在每个子文件夹中的文件的末尾空白行。 –

@ayyappankm好的，那么这应该工作。 – Moosli

嗨Moosli，感谢您的帮助，它的工作正常 –

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

回答

相关问题