Dim arr(), m&
Sub Macro1()
Dim Fso As Object, a, i&, j&, n&, brr()
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
p = ThisWorkbook.Path & "\2012-3-1"
sFileType = "*.pdf"
Call GetFiles(p, sFileType, Fso)
ReDim brr(1 To m, 1 To 4)
[a1].CurrentRegion.Offset(1).ClearContents
With ActiveSheet
For i = 1 To m
a = Split(arr(i), "\")
n = 0
For j = UBound(a) - 3 To UBound(a) - 1
n = n + 1
brr(i, n) = a(j)
Next
brr(i, 4) = Replace(a(j), ".pdf", "") '
.Hyperlinks.Add Anchor:=Cells(i + 1, 4), Address:=arr(i)
Next
End With
[a2].Resize(m, 4) = brr
m = 0
Erase arr
Set Fso = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object)
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Set Folder = Fso.GetFolder(sPath)
For Each File In Folder.Files
If File.Name Like sFileType Then
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = sPath & "\" & File.Name
End If
Next
If Folder.SubFolders.Count > 0 Then
For Each SubFolder In Folder.SubFolders
Call GetFiles(SubFolder.Path, sFileType, Fso)
Next
End If
Set Folder = Nothing
Set File = Nothing
Set SubFolder = Nothing
End Sub