Sub TestCreateFileListAndHyperlinks( _
Criteria As String, _
SearchPath As String, _
IncludeSubfolders As Boolean, _
OutputCol As Variant, _
Optional HyperlinkCol As Variant)
Dim FileNamesList As Variant
Dim oCol As Integer 'Text Output Column Number
Dim hCol As Integer 'Hyperlink Output Column
Dim i As Integer 'Loop Counter
Dim addHL As Boolean 'Hyperlink column passed
'// ———————————————————————————————————————————————————————————————————————
'// Output Range
'// First output Row
Const START_ROW = 2
'// Clear to row
Const LAST_ROW = 30
'// ———————————————————————————————————————————————————————————————————————
'// Output column
oCol = Columns(OutputCol).Column
'// Hyperlink column
If Not IsMissing(HyperlinkCol) And HyperlinkCol <> "" Then addHL = True
If addHL Then hCol = Columns(HyperlinkCol).Column
'// ———————————————————————————————————————————————————————————————————————
'// Directory and File Search Operations
'//
'// Create file list that matches Criteria with seperate Function
FileNamesList = CreateFileList(Criteria, SearchPath, IncludeSubfolders)
'// ———————————————————————————————————————————————————————————————————————
'// Clear Contents of Output Row Excluding First Row
Range(Cells(START_ROW, oCol), Cells(LAST_ROW, oCol)).ClearContents
If addHL And oCol <> hCol Then _
Range(Cells(START_ROW, hCol), Cells(LAST_ROW, hCol)).ClearContents
'// ———————————————————————————————————————————————————————————————————————
'// Check if directory exists
If Dir(SearchPath, vbDirectory) = "" Then
MsgBox SearchPath & vbCr & vbCr & "Doesn't exist or is not accessible"
Exit Sub
End If
'// ———————————————————————————————————————————————————————————————————————
'// Results Output
'//
'// Set Default value if criteria was not found in search folder
'// will be overwritten if criteria finds match
Cells(START_ROW, Columns(OutputCol).Column).Formula = "No Criteria Match"
'// Error handling to prevent errors if array is empty
On Error Resume Next
For i = 1 To UBound(FileNamesList)
'// Path Output
If oCol <> hCol Then
Cells(i + 1, oCol).Formula = FileNamesList(i)
End If
If addHL Then
'// Hyperlink Output
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells((i - 1) + START_ROW, hCol), _
Address:=FileNamesList(i), _
TextToDisplay:= _
Mid(FileNamesList(i), InStrRev(FileNamesList(i), "\") + 1)
End If
Next i
On Error GoTo 0
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value & "*.jpg", _
SearchPath:="Z:\Seagate", _
IncludeSubfolders:=True, _
OutputCol:="B", _
HyperlinkCol:="B"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value & "*.pdf", _
SearchPath:="C:\Folder2", _
IncludeSubfolders:=True, _
OutputCol:="C", _
HyperlinkCol:="C"
TestCreateFileListAndHyperlinks _
Criteria:="*" & Range("A1").Value & "*.log", _
SearchPath:="C:\Folder3", _
IncludeSubfolders:=True, _
OutputCol:="D", _
HyperlinkCol:="D"
TestCreateFileListAndHyperlinks _
Criteria:="*" & Range("B1").Value & "*.*", _
SearchPath:="C:\Folder4", _
IncludeSubfolders:=True, _
OutputCol:="E", _
HyperlinkCol:="E"
End If
End Sub
Function CreateFileList( _
FileFilter As String, _
SearchFolder As String, _
IncludeSubfolders As Boolean) As Variant
' returns the full filename for files matching
' the filter criteria in the passed folder
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
If FileFilter = "*.*" Then FileFilter = "*.*" ' all files
With Application.FileSearch
.NewSearch
.LookIn = SearchFolder
.Filename = FileFilter
.SearchSubFolders = IncludeSubfolders
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim FileList(.FoundFiles.Count)
For FileCount = 1 To .FoundFiles.Count
FileList(FileCount) = .FoundFiles(FileCount)
Next FileCount
.FileType = msoFileTypeExcelWorkbooks ' reset filetypes
End With
CreateFileList = FileList
Erase FileList
End Function
