List of all files in Folder / Sub Folder with Hyperlink - vba

Question

I am using this code to list out files in folder and sub-folder. The code is working fine. But if there is no sub-folder I get an error in the below line.
'Files under current dir
fname = Dir(fPath & "*." & fType).
And I want message-box option (Yes/no) for empty folders. (Currently its showing all empty folders)
Public oldNR As Long
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: xls, doc, txt, pdf, *)", "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 = 4
With ActiveSheet
.Range("A:C").Clear
.[A2] = "LIST OF FILES"
.[B2] = "Modified Date"
Call FindFilesAndAddLinks(fPath, fType, NR, AddLinks)
End With
With ActiveSheet
.Range("A:B").Columns.AutoFit
.Range("B:B").HorizontalAlignment = xlCenter
Range("B:B").Select
Selection.NumberFormat = "d-mmm-yy h:mm AM/pm"
End With
With ActiveSheet
Range("A2").Select
Selection.Font.Bold = True
Range("B2").Select
Selection.Font.Bold = True
Columns("A:A").Select
Selection.Font.Underline = xlUnderlineStyleNone
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 ActiveSheet
'Write folder name
.Range("A" & NR) = fPath
.Range("A" & NR).Select
If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
Address:=fPath, _
TextToDisplay:="FOLDER NAME: " & " " & UCase(Split(fPath, "\")(UBound(Split(fPath, "\")) - 1))
Selection.Font.Bold = True
Selection.Font.Size = 10
Selection.Font.Name = "Arial"
Selection.Font.Underline = xlUnderlineStyleNone
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
NR = NR + 2
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:=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
ActiveWindow.DisplayGridlines = False
End Sub