Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="[COLOR=Red]Z:\Seagate[/COLOR]", _
IncludeSubfolders:=True, _
OutputCol:="B", _
HyperlinkCol:="B"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\FOLDER2", _
IncludeSubfolders:=True, _
OutputCol:="C", _
HyperlinkCol:="C"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\FOLDER3", _
IncludeSubfolders:=True, _
OutputCol:="D", _
HyperlinkCol:="D"
TestCreateFileListAndHyperlinks _
Criteria:=Range("A1").Value, _
SearchPath:="C:\FOLDER4", _
IncludeSubfolders:=True, _
OutputCol:="E", _
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 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
'//
'// Create file list that matches Criteria with seperate Function
FileNamesList = CreateFileList(Criteria & "*.*", SearchPath, IncludeSubfolders)
'// ———————————————————————————————————————————————————————————————————————
'// Clear Contents of Output Row Excluding First Row
'// Clear Contents of Output Row Excluding First Row
Range(Cells(2, oCol), Cells(30, oCol)).ClearContents
If addHL And oCol <> hCol Then _
Range(Cells(2, hCol), Cells(30, hCol)).ClearContents
'// ———————————————————————————————————————————————————————————————————————
'// Results Output
'//
'// Set Default value if criteria was not found in search folder
'// will be overwritten if criteria finds match
Cells(2, 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 + 1, oCol).Formula = FileNamesList(i)
If addHL Then
'// Hyperlink Output
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(i + 1, 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, _
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
