Autohyperlink to and replace file names in worksheet

Hi,

I found this very useful code posted by "austenr", but I need it to do something more in vers. Excel 2003. While keeping the browse to select directory functionality, I would like it to loop through all columns and fields in the current worksheet and look for strings (filenames) stored in the fields that match files (.pdf) in the current directory selected. Then it would be great if it could replace the file names wit:bow: h actual hyperlinks to the files themselves when a match is found. I know this is challenging (impossible for me) so any help will be very strongly appreciated. The existing code, again credited to "austenr" who has saved me many hours of manually hyperlinking, is the following:

[VBA]
Option Explicit

Sub SrchForFiles()
' Searches the selected folders and sub folders for files with the specified
'extension. .xls, .doc, .ppt, etc.
'A new worksheet is produced called "File Search Results". You can click on the link and go directly
'to the file you need.
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String

y = Application.InputBox("Please Enter File Extension", "Info Request")
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
'**********************************************************************
'fLdr = BrowseForFolderShell
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fLdr = .SelectedItems(1)
End With
'**********************************************************************
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error Goto 1
2: ws.Name = "FileSearch Results"
On Error Goto 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fil = .FoundFiles(i)
'Get file path from file name
FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1)
If Left$(Fil, 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(Fil))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 4) = _
Array(Dir(Fil), _
FileLen(Fil) / 1000, _
FileDateTime(Fil), _
FPath)
ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False

With ws
Rw = .Cells.Rows.Count
With .[A1:D1]
.Value = [{"Full Name","Kilobytes","Last Modified", "Path"}]
.Font.Underline = xlUnderlineStyleSingle
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[E1:IV1 ].EntireColumn.Hidden = True
On Error Resume Next
Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
End With

Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
Goto 2
End Sub
[/VBA]

Work from the other side. Get the file names and search the sheet
[VBA]
Option Explicit
Sub SrchForFiles()
Dim fLdr, Fil As String, FPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fLdr = .SelectedItems(1)
End With
Fil = Dir(fLdr & "\*.pdf")
Do Until Fil = ""
AddLink fLdr & "\" & Fil
Fil = Dir
Loop
End Sub

Sub AddLink(FName As String)
Dim pdf As String
Dim c As Range
Dim FirstAddress As String
pdf = Split(FName, "\")(UBound(Split(FName, "\")))
With ActiveSheet.Cells
Set c = .Find(pdf, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
ActiveSheet.Hyperlinks.Add Anchor:=c, Address:=FName, TextToDisplay:=pdf
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End Sub

[/VBA]

Thanks for the reply, I'm going to try that first thing am

It doesn't do anything, but i can hear the hardrive spin up for a moment. I think maybe the search until null thing is just causing it to exit ??

Can you post some sample data to show typical references where the links should be created. I've assumed the cells contain "test.pdf" or the like.