Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\TEST1", _
IncludeSubfolders:=True, _
OutputCol:="X", _
HyperlinkCol:="B"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\TEST2", _
IncludeSubfolders:=True, _
OutputCol:="Y", _
HyperlinkCol:="C"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\TEST3", _
IncludeSubfolders:=True, _
OutputCol:="Z", _
HyperlinkCol:="D"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\TEST4", _
IncludeSubfolders:=True, _
OutputCol:="AA", _
HyperlinkCol:="E"
End If
End Sub
Sub TestCreateFileListAndHyperlinks( _
Criteria As String, _
SearchPath As String, _
IncludeSubfolders As Boolean, _
OutputCol As String, _
Optional HyperlinkCol As String)
Dim FileNamesList As Variant
Dim startDir As String
Dim oCol As Integer
Dim hCol As Integer
Dim i As Integer
Dim addHL As Boolean
'// ———————————————————————————————————————————————————————————————————————
'// Check if directory exists
If Dir(SearchPath, vbDirectory) = "" Then
MsgBox "PATH:" & SearchPath & " — doesn't exist or is not accessible"
Exit Sub
End If
If Not IsMissing(HyperlinkCol) And HyperlinkCol <> "" Then addHL = True
oCol = Columns(OutputCol).Column
If addHL Then hCol = Columns(HyperlinkCol).Column
'// ———————————————————————————————————————————————————————————————————————
'// Directory and File Search Operations
'//
'// Store the Current Directory
startDir = CurDir()
'// Set the search directory
ChDir SearchPath
'// Create file list that matches Criteria with seperate Function
FileNamesList = CreateFileList(Criteria & "*.*", IncludeSubfolders)
'// Restore current current Directory to previous path
ChDir startDir
'// ———————————————————————————————————————————————————————————————————————
'// Clear Contents of Output Row Excluding First Row
Range(Cells(3, oCol), Cells(Rows.Count, oCol)).ClearContents
If addHL Then Range(Cells(3, hCol), Cells(Rows.Count, hCol)).ClearContents
'// ———————————————————————————————————————————————————————————————————————
'// Results Output
'//
'// Set Default value if criteria was not found in search folder
'// will be overwritten if criteria finds match
Cells(3, Columns(OutputCol).Column).Formula = "No Match to Criteria"
'// Error handling to prevent errors if array is empty
On Error Resume Next
For i = 1 To UBound(FileNamesList)
'// Path Output
Cells(i + 2, oCol).Formula = FileNamesList(i)
If addHL Then
'// Hyperlink Output
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(i + 2, hCol), _
Address:=FileNamesList(i), _
TextToDisplay:= _
Mid(FileNamesList(i), InStrRev(FileNamesList(i), "\") + 1)
End If
Next i
On Error GoTo 0
End Sub
Function CreateFileList(FileFilter As String, _
IncludeSubfolders As Boolean) As Variant
' returns the full filename for files matching
' the filter criteria in the current folder
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
If FileFilter = "*.*" Then FileFilter = "*.*" ' all files
With Application.FileSearch
.NewSearch
.LookIn = CurDir
.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
