Search a directory for a cell value and list folders that contain this value.

[Bagsy]

I understand this is probably a bit of an ask or if it is actually possible, but here goes.
Could somebody please help a bit here, I don’t even know how to start to build this code.

What I would like to achieve is to search in folder W:\1WORKS MANAGERS FILES\WIS FILES DEAD and all subfolders within that folder for a text string in Cell B3. (Which is a drawing number). This can appear as a PDF drawing name, file name or on excel or word documents within the folders being searched)
W:\1WORKS MANAGERS FILES\WIS FILES DEAD has 300+ folders each of these has several subfolders within them.

W:\1WORKS MANAGERS FILES\WIS FILES DEAD

12345 Folder 1
---------Correspondence
---------------Subfolder 1
---------------Subfolder 2
--------------------Sub-Subfolder3 …etc
----------Drawings
---------------Subfolder 1
---------Quotes
---------------Subfolder 1
---------Layout photos
---------Cost sheet
---------Etc

12346 Folder 2
12347 Folder 3

What I am trying to achieve is for the code to search for the drawing number in “B3” then list the parent folders within W:\1WORKS MANAGERS FILES\WIS FILES DEAD
If the code finds the required drawing number in “Subfolder 1” as below
12345 Folder 1
------Correspondence
---------Subfolder 1
Then it should list “12345 Folder 1” on my sheet.

Please note this drawing number will appear in several folders & I would like to list them all.
I need to get these file names on an excel sheet so I can then check if they are listed on another excel document.
This is probably going to be beyond my skill level but would like to give it a try, any help at all would be gratefully received.

 

[Bagsy]

Hi DanteAmor
Thanks for this
When I run the code post #8, I get an error "object variable with block variable not set" with this line highlighted
rutas.Add sPath

 

[DanteAmor]

My fault, failed to include the first line of the code:

Dim rutas As New Collection

Sub Search_directory()
  Dim sPath As String, arch As Variant, sd As Variant, i As Long
  Dim sh1 As Worksheet, wb2 As Workbook, sh2 As Worksheet
  Dim f As Range, sValue As Variant
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = ActiveSheet
  sValue = sh1.Range("B3")
  If sValue = "" Then
    MsgBox "Enter a value"
    Exit Sub
  End If
  '
  Set rutas = Nothing
  sPath = "C:\Sub-Contract\"
  '
  rutas.Add sPath
  Call AddSubDir(sPath)
  '
  Range("C3:D" & Rows.Count).ClearContents
  i = 3
  For Each sd In rutas
    arch = Dir(sd & "\*.xls*")
    Do While arch <> ""
      Set wb2 = Workbooks.Open(sd & "\" & arch, False, True)
      For Each sh2 In wb2.Sheets
        Set f = sh2.Cells.Find(sValue, , xlValues, xlPart)
        If Not f Is Nothing Then
          sh1.Range("C" & i).Value = sd
          'Range("D" & i).Value = arch
          i = i + 1
          Exit For
        End If
      Next
      wb2.Close False
      arch = Dir()
    Loop
  Next
  '
  MsgBox "End"
End Sub
'
Sub AddSubDir(lpath)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
  DirFile = Dir(lpath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then _
      If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then SubDir.Add lpath & DirFile
    DirFile = Dir
  Loop
  For Each sd In SubDir
    rutas.Add sd
    Call AddSubDir(sd)
  Next
End Sub

 

[Bagsy]

Hi DanteAmor

Apologies this is taking up your time, I really do appreciate your help

To test the code I have set up a folder “W:\Sub-Contract\Test\” with some dummy folders in it.
I then modified your code to search a test folder I have set up
sPath = "W:\Sub-Contract\Test\” This is where I have the excel sheet with the number typed I am searching for.

Your code worked great and listed the folder the excel file is in as below
W:\Sub-Contract\Test\46758 HEL 24 X test blocks Type 2\19. Correspondence

Is it possible just to list the folder without “W:\Sub-Contract\Test\” in front, as below
46758 HEL 24 X test blocks Type 2\19. Correspondence

Gary

 

[DanteAmor]

Change this line
sh1.Range("C" & i).Value = sd

for this:
sh1.Range("C" & i).Value = Mid(sd, Len(sPath) + 1)

 

[Bagsy]

DanteAmor
That is absolutely brilliant, thank you so much for your help. Sorry it took so long

Gary

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.