Bom dia!!

Eu não baixei seu anexo...

Talvez isso te ajude...

Sub teste()
     MsgBox FindFile("C:", "Teste.xls")
End Sub

Function FindFile(ByVal strPath As String, ByVal strFile As String) As String
                  
    Static fso As Object
    Dim fsoSubfolder As Object
    
    FindFile = "0"  
    
    If fso Is Nothing Then
        Set fso = CreateObject("Scripting.FileSystemObject")
    End If
    
    If Right(strPath, 1) <> "" Then strPath = strPath & ""
    
    On Error Resume Next
    If Len(Dir(strPath & strFile)) Then
        FindFile = strPath
    Else
        'Search sub folders
        If fso.GetDrive(strPath).RootFolder = strPath Then
            For Each fsoSubfolder In fso.GetDrive(strPath).RootFolder.SubFolders
                FindFile = FindFile(fsoSubfolder.Path, strFile)
                If FindFile <> "0" Then Exit For
            Next fsoSubfolder
        Else
            For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
                Debug.Print fsoSubfolder.Path
                FindFile = FindFile(fsoSubfolder.Path, strFile)
                If FindFile <> "0" Then Exit For
            Next fsoSubfolder
        End If
    End If

End Function

Fonte: http://excelnoob.blogspot.com.br/2010/07/excel-vba-loop-through-all-files-and.html

Private fileCounter As Integer
Private activeSht As Worksheet
'Display all the files in a folder. Searches all the sub folders.

'Prints Folder Names in Column A and and the file Names in Column B

Sub SearchFiles()
    Dim pth As String
    Dim fso As FileSystemObject
    Dim baseFolder As Folder
                    
    pth = "C:Projects" 'the base path which has to be searched for Files
    Set fso = New FileSystemObject
                    
    ''check if the folder actually exists or not
                    
    If (Not (fso.FolderExists(pth))) Then
        'the folder path is invalid. Exiting.
        MsgBox "Invalid Path"
        Exit Sub
    End If
    
    Set baseFolder = fso.GetFolder(pth)
    
    fileCounter = 1
    Set activeSht = ActiveSheet
    
    activeSht.Range("A1").Value = "Folder Name"
    activeSht.Range("B1").Value = "File Name"
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    PrintFileNames baseFolder
    
ErrHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub PrintFileNames(baseFolder As Folder)
    Dim folder_ As Folder
    Dim file_ As File
    
    For Each folder_ In baseFolder.SubFolders
        'call recursive function.
        PrintFileNames folder_
    Next folder_
    
    For Each file_ In baseFolder.Files
        'print files here
        activeSht.Range("A1").Offset(fileCounter, 0).Value = baseFolder.Path
        activeSht.Range("B1").Offset(fileCounter, 0).Value = file_.Name
        fileCounter = fileCounter + 1
    Next file_
End Sub
    

Att

Esse código abaixo funcioou,
Porém ele me retorna todos os arquivos e é muittaaa coisa..queria que ele me retornasse apenas "sim ou "não" ou qualquer coisa, se tiver algo dentro da pasta.
a idéia seria imprimir apenas uma linha por pasta.

Você conseguiria ajustar?

Private fileCounter As Integer
Private activeSht As Worksheet
'Display all the files in a folder. Searches all the sub folders.


'Prints Folder Names in Column A and and the file Names in Column B

Sub SearchFiles()
    Dim pth As String
    Dim fso As FileSystemObject
    Dim baseFolder As folder
    Dim dir As String
    Dim folder As String
    
    dir = "meu_diretório"
                    
                    
    pth = dir & folder
    Set fso = New FileSystemObject
                    
    ''check if the folder actually exists or not
                    
    If (Not (fso.FolderExists(pth))) Then
        'the folder path is invalid. Exiting.
        MsgBox "Invalid Path"
        Exit Sub
    End If
    
    Set baseFolder = fso.GetFolder(pth)
    
    fileCounter = 1
    Set activeSht = ActiveSheet
    
    activeSht.Range("A1").Value = "Folder Name"
    activeSht.Range("B1").Value = "File Name"
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    PrintFileNames baseFolder
    
ErrHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub PrintFileNames(baseFolder As folder)
    Dim folder_ As folder
    Dim file_ As File
    
    For Each folder_ In baseFolder.SubFolders
        'call recursive function.
        PrintFileNames folder_
    Next folder_
    
    For Each file_ In baseFolder.Files
        'print files here
        activeSht.Range("A1").Offset(fileCounter, 0).Value = baseFolder.Path
        activeSht.Range("B1").Offset(fileCounter, 0).Value = file_.Name
        fileCounter = fileCounter + 1
    Next file_
End Sub

Boa tarde!!

Caio, tente adaptar esse..

Sub EncontrarArquivo()
   Dim StrFile As String, objFSO, destRow As Long, fname As String
   Dim mainFolder, mySubFolder
   mFolder = Range("B2").Value
   fname = Range("B3").Value
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set mainFolder = objFSO.GetFolder(mFolder)
   StrFile = Dir(mFolder & "" & fname)
   If StrFile <> "" Then
      Workbooks.Open mFolder & "" & StrFile
   Else
      SubFoldersScan OfFolder:=mainFolder, fname:=fname
   End If
End Sub

Sub VarrerArquivo(OfFolder As Variant, fname As String)
    Dim SubFolder
    For Each SubFolder In OfFolder.SubFolders
       StrFile = Dir(SubFolder & "" & fname)

       If StrFile <> "" Then
          Workbooks.Open SubFolder & "" & StrFile
          Exit For
       End If
       SubFoldersScan OfFolder:=SubFolder, fname:=fname
    Next SubFolder
End Sub

Att

Caio, se ainda não resolveu esta questão segue um exemplo, lembrando que utilizei a Arvore de Diretório conforme a figura abaixo :

Ou sejano Root C:Arquivos - Se alterar o Local das Pastas tem de ajustar na rotina, no exemplo deixei o Caminho principal "C:Arquivos" em um Range, mas pode ser definido diretamente na Rotina, e as Subpastas e Tipos dos Arquivos estão nos Ranges.

Faça os Testes e veja se é isto :

Lista Arquivos para Pastas e Tipos

Qualquer duvida, retorne.

[]s