try:
Sub Search_myFolder_Network()
Dim myFolder As String
Dim myRange As Range, colFiles As New Collection
Dim arrNames() As Variant, arrMsg, r As Long, msg As String, nm, fName
Dim cel As Range
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.InitialFileName = Application.DefaultFilePath & "\"
If .Show = 0 Then Exit Sub
myFolder = .SelectedItems(1)
End With
Call RecursiveDir(colFiles, myFolder, "*.*", True)
ReDim arrNames(1 To colFiles.Count)
Set myRange = Application.Selection
'arrNames = myRange 'assumes one-column contiguous range is selected
If IsEmpty(myRange) Then
Debug.Print "Empty"
Exit Sub
End If
For Each cel In myRange
r = r + 1
'For r = 0 To UBound(arrNames, 1)
msg = "File not found" 'reset message
'fName = arrNames(r, 1)
fName = cel & ""
If Len(fName) <> 0 Then
For Each nm In colFiles 'loop over all found file names
If InStr(1, nm, fName, vbTextCompare) > 0 Then
'msg = "File exists"
msg = "Found " & fName & " in " & Replace$(nm, fName, "")
Debug.Print msg
Exit For 'stop checking
End If
Next nm
arrNames(r) = msg 'replace file name with result message
End If
Next cel
myRange.Offset(0, 1).Value = arrNames 'write the results to the next column
End Sub
' arnelgp
Public Sub RecursiveDir(ByRef colFiles As Collection, _
ByVal strFolder As String, _
ByVal strFileSpec As String, _
Optional ByVal bIncludeSubfolders As Boolean = False)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
On Error Resume Next
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Sub
Private Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function