目錄中的文件夾子文件夾中的文件列表

我正在使用此代碼列出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，感謝您的幫助，它的工作正常 –

目錄中的文件夾子文件夾中的文件列表

回答

相關問題