ZerP
10-06-2022, 10:31 PM
: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
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