List of Files in Folder Sub Folder in Directory - excel

Question

I am using this code to list out all the files in Folder and Sub Folder in Excel. This code is working fine. I want to leave one blank row for each sub folder. currently its list out continuously in all the rows. Please help.
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

The changed FindFilesAndAddLinks below will create the following format:
FolderRoot\Folder1\Subfolder1
FolderRoot\Folder1\Subfolder1\FirstFileFound
FolderRoot\Folder1\Subfolder1\SecondFileFound
FolderRoot\Folder2\Subfolder2
FolderRoot\Folder2\Subfolder2\FirstFileFound
FolderRoot\Folder2\Subfolder2\SecondFileFound
...
New macro:
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

Hi i'm not sure what do you mean with Blank Row for a subfolder. But i think if you add NR = NR+1 in the Subfolder Loop, it should wor fine.
'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