Search for a match files using value from selected cell in Folder or Subfolders

[ZerP]

:hi:
I'm New Here and a novice in vba.
I need help, I have a project in my work that need to check if a file exist from our network file server that have multiple subfolder I'm using selected cells as search reference from my worksheet.
I supposed to search a file or multiple files, but my code only work for selected multiple cells only, I need it to search even if I select only 1 cell, I got error miss match if I do so.

Thanks in advance
Here's the code I'm working with

Sub Search_myFolder_Network()
Dim myFolder As String
Dim myRange As Range, colFiles As Collection
Dim arrNames, arrMsg, r As Long, msg As String, nm, fName

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.InitialFileName = Application.DefaultFilePath & "\"
If .Show = 0 Then Exit Sub
myFolder = .SelectedItems(1)
End With

Set colFiles = AllFileNames(myFolder)

Set myRange = Selection
arrNames = myRange.Value 'assumes one-column contiguous range is selected

For r = 1 To UBound(arrNames, 1)
msg = "File not found" 'reset message
fName = arrNames(r, 1)
For Each nm In colFiles 'loop over all found file names
If InStr(1, nm, fName, vbTextCompare) > 0 Then
msg = "File exists"
Debug.Print "Found " & fName & " in " & nm
Exit For 'stop checking
End If
Next nm
arrNames(r, 1) = msg 'replace file name with result message
Next r

myRange.Offset(0, 1).Value = arrNames 'write the results to the next column


End Sub


'Return a collection of unique file names given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function AllFileNames(startFolder As String, Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection

Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & "*.*") 'Dir is faster...
Do While Len(f) > 0
On Error Resume Next 'ignore error if key is already added
colFiles.Add f, f
On Error GoTo 0 'stop ignoring errors
f = Dir()
Loop
Loop
Set AllFileNames = colFiles
End Function

[arnelgp]

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

[ZerP]

Hi Thank you very much for your quick response, I have tested your code just now, I really appreciate your new input with my code - the printing of path and file name with the result, but unfortunately when I'm searching (selecting) multiple cells the printed results are all the same; it seems the result for 1st selected cell is being copied to the rest of the selection so it seems like it only search the 1st cell in the selection. And is there a way to print the result in separate column, like for example column C (file name to be search);next column- result if Found or not; then next column the file path only and next the full file name.
I know this is too much, thanks you in advance

[arnelgp]

it would be best to show me your worksheet.
and whatever filename you have on it, i will
try to replicate it locally.

[mana]

＞so it seems like it only search the 1st cell in the selection

myRange.Offset(0, 1).Value = Application.Transpose(arrNames)

[snb]

This code is sufficient:


Sub M_snb()
With Application.FileDialog(4)
.InitialFileName = Application.DefaultFilePath & "\"
If .Show Then c00 = .SelectedItems(1)
End With

With CreateObject("wscript.shell")
For Each it In Selection
c01 = c01 & vbLf & .exec("cmd /c dir """ & c00 & "\*" & it & """*.* /b /s").stdout.readall
Next
End With

MsgBox c01
End Sub

[mana]

Option Explicit


Sub test()
Dim dic As Object
Dim fdg As FileDialog, p As String
Dim cmd As String, s, k As Long
Dim fn As String
Dim c As Range, msg As String

Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
If Not fdg.Show Then Exit Sub
p = fdg.SelectedItems(1) & "\"

Set dic = CreateObject("scripting.dictionary")

cmd = "cmd /c dir """ & p & "*.*"" /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
For k = 0 To UBound(s) - 1
fn = Dir(s(k))
dic(fn) = dic(fn) & " , " & Left(s(k), InStrRev(s(k), "\") - 1)
Next

For Each c In Selection
fn = c.Value
If dic.exists(fn) Then
msg = "Found in " & Mid(dic(fn), 3)
Else
msg = "not found"
End If
c.Offset(, 1).Value = msg
Next


End Sub

[mana]

Option Explicit


Sub test2()
Dim dic As Object
Dim fdg As FileDialog, p As String
Dim cmd As String, s, k As Long
Dim fn As String
Dim c As Range, msg As String

Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
If Not fdg.Show Then Exit Sub
p = fdg.SelectedItems(1) & "\"

Set dic = CreateObject("scripting.dictionary")

cmd = "cmd /c dir """ & p & "*.*"" /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
For k = 0 To UBound(s) - 1
fn = Dir(s(k))
dic(fn) = dic(fn) & " , " & s(k)
Next

For Each c In Selection
fn = c.Value
s = Filter(dic.keys, fn)
msg = ""
If UBound(s) > -1 Then
For k = 0 To UBound(s)
msg = msg & dic(s(k))
Next
msg = "Found in " & Mid(msg, 3)
Else
msg = "not found"
End If
c.Offset(, 1).Value = msg
Next


End Sub

[snb]

@mana

the /s option shows the fullname of every file.
You don't need any Dir, nor a Dictionary.

[mana]

oh! just a waste of time!! :doh:

[ZerP]

Hi Mana and arnelgp,
Thanks for your suggestion, I change the code with this "myRange.Offset(0, 1).Value = Application.Transpose(arrNames)" and it works, I just use excel formula to separate the string to individual column.

The issue is it takes longer to search and print the result.

30232
30233

I noticed that when I'm trying to search from 1 single folder directory it load fast but when the directory contains multiple subfolders it took me 3 mins to search 25 file.
But for now I'll make used of it as long as it works.

Thanks you all so much for your time and assistance.