Excel VBA: Search Folder and Sub-Folders for Part Numbers Listed in Excel - excel

Question

Beginner in VBA so sorry if the code is bad.
What I wanted to achieve was to search a folder and its sub folders for the .dxf file of a part number listed in Column B, and return either a "Yes" or "No" depending on whether that .dxf file exist in that folder or its sub folders.
What I expected was that the code would begin with the first part number listed in B2, search the folder and sub folders for the .dxf file related, return a value, then move on to the next one, B3 then B4 and so on until the part numbers stop.
What it does is search a folder for all listed part numbers in Column B, returns all values, then searches a subfolder, returns all values (overriding the previous results) and so on until there are no more subfolders to search.
I feel like I'm close to getting the result I want but not sure where I've gone wrong.
Code is below:
Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Sub FindFile()
HostFolder = "C:\Users\Anyone\DXF\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim Row As Integer
Dim Extension As String
Dim Continue As Boolean
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
Continue = True
Extension = ".DXF"
Row = 2
While Continue
If Len(Range("B" & CStr(Row)).Value) = 0 Then Exit Sub
If Len(Dir(Folder.Path & "\" & Range("B" & CStr(Row)).Value & "*" & Extension)) = 0 Then
Range("F" & CStr(Row)).Value = "No"
Else
Range("F" & CStr(Row)).Value = "Yes"
End If
Row = Row + 1
Wend
Next
End Sub

Answer 1

I would rethink the approach here. Maybe try a macro to manage the row loop and a function to manage the file lookup
First macro to loop through all file names in Column B and outputs if a file is found in Column C
Second macro to search a folder/subfolder path. If the file is found, the loop ends and returns TRUE. If a file is not found, the macro runs it's course and exists with FALSE
Note the function is just demonstrating the logic. You just need to take the logic you have to manage the folder loop and implement in this function
Sub File_Range()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If Not IsEmpty(ws.Range("B" & i)) Then
ws.Range("C" & i) = File_Exists(Range("B" & i))
End If
Next i
End Sub
Public Function File_Exists(Target As Range) As Boolean
'False until file is found
File_Exists = False
For Each SubFolder In Folder.SubFolders
If Len(Dir(Folder.Path & "\" & Target.Value & "*" & Extension)) Then
File_Exists = True
Exit Function
End If
Next SubFolder
End Function

Answer 2

Check Files for Existence
The Basics
Basically (inaccurately), the following writes all file paths of the required (DXF) files found in the supplied folder path to an array, replaces them with file names without file extension and checks the values (file names) in the source column against the array and finally writes the required results (Yes/No) to the destination column.
Adjust the values in the constants section.
Only run checkFiles, the rest is being called by it.
Additional Functionality
To better understand the flow, in the Immediate window CTRL+G, you can monitor what is happening, if you uncomment the Debug.Print sections. Note that Join will fail if error values, but you can always create a loop like it is done for mData which possibly (probably) contains error values.
It will allow different worksheets for source and destination data.
If will allow source and destination data starting in different rows.
The Code
Option Explicit
Sub checkFiles()
Const FolderPath As String = "C:\Users\Anyone\DXF"
Const FileExt As String = "DXF" ' Not case-sensitive i.e. 'DXF = dxf'
Const fFound As String = "Yes"
Const fNotFound As String = "No"
Const srcName As String = "Sheet1"
Const srcFirst As String = "B2"
Const dstName As String = "Sheet1"
Const dstFirst As String = "F2"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim rng As Range ' (Source and Destination) Data Range
Dim Data As Variant ' (Source and Destination) Data Array
Dim fData() As String ' File Data Array
Dim mData As Variant ' Match Data Array
Dim n As Long ' File Data and (Match) Data Array Elements Counter
' Write values from Source Range to Data Array.
Set rng = defineColumnRange(defineRange(wb.Worksheets(srcName), srcFirst))
Data = getColumn(rng)
'Debug.Print "Source Data:" & vbLf & Join(Application.Transpose(Data), vbLf)
' Write file paths to File Data Array.
fData = getFilePaths(FolderPath, "*." & FileExt)
'Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
' Replace file paths with file names without file extension.
For n = LBound(fData) To UBound(fData)
fData(n) = FileFromPath(fData(n), True) ' 'True' means no extension.
Next n
'Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
' Write 'matches' to Match Data Array.
mData = Application.Match(Data, fData, 0)
'Debug.Print "Match Data:"
'For n = 1 To UBound(mData)
' Debug.Print mData(n, 1)
'Next
' Overwrite values in Data Array with 'matching results'.
For n = 1 To UBound(Data) ' or 'UBound(mData)'
If IsNumeric(mData(n, 1)) Then
Data(n, 1) = fFound
Else
Data(n, 1) = fNotFound
End If
Next n
'Debug.Print "Destination Data:" & vbLf _
& Join(Application.Transpose(Data), vbLf)
' Write values from Data Array to Destination Range.
With defineRange(wb.Worksheets(dstName), dstFirst)
Dim RowOffset As Long: RowOffset = .Row - rng.Row
Dim ColumnOffset As Long: ColumnOffset = .Column - rng.Column
Set rng = .Worksheet.Range(rng.Offset(RowOffset, ColumnOffset).Address)
End With
rng.Value = Data
End Sub
Function defineRange( _
ws As Worksheet, _
ByVal RangeAddress As String) _
As Range
On Error Resume Next
Set defineRange = ws.Range(RangeAddress)
On Error GoTo 0
End Function
Function defineColumnRange( _
FirstCell As Range) _
As Range
If Not FirstCell Is Nothing Then
With FirstCell
Dim rng As Range
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
If Not rng Is Nothing Then
Set defineColumnRange = .Resize(rng.Row - .Row + 1)
End If
End With
End If
End Function
Function getColumn( _
rng As Range) _
As Variant
If Not rng Is Nothing Then
If InStr(rng.Address, ":") > 0 Then
getColumn = rng.Value
Else
Dim Data As Variant
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
getColumn = Data
End If
End If
End Function
Function getFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "") _
As Variant
Dim ExecString As String
ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
& FilePattern & """ /b/s"
getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf), ".") ' 'vbCrLf' is a must.
End Function
Function FileFromPath( _
ByVal FilePath As String, _
Optional ByVal NoExtension As Boolean = False) _
As String
Dim FileName As String
FileName = Right(FilePath, _
Len(FilePath) - InStrRev(FilePath, "\"))
If NoExtension Then
FileName = Left(FileName, InStrRev(FileName, ".") - 1)
End If
FileFromPath = FileName
End Function