Search for a file in subfolders

**Roger Roth** · 06-15-2015, 01:59 PM

I am trying to search all subfolders for a file to eliminate possible duplicate file names. Any help would be appreciated.

[code]
Sub UPDATE()
Application.EnableCancelKey = xlInterrupt
On Error GoTo ENDTHISSUB
RNC = 2
Sheets("G-DRIVE").Select
Do While Cells(RNC, 2) <> ""
GoSub MOVEGDRIVE
RNC = RNC + 1
MSGC = MsgBox("CONTINUE?", vbYesNo)
If MSGC = vbNo Then Exit Do
Loop
GoTo ENDTHISSUB
MOVEGDRIVE:
MSGF = vbYes
GoSub MOVEFILE
If MSGF = vbNo Then Return
Cells(RNC, 3).Select
Range(ActiveCell, ActiveCell.Offset(0, 1)).Select
Selection.Copy
Sheets("INVAULT").Select
RNP = Cells(1, 5)
Cells(RNP, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
RNP = RNP + 1
Cells(1, 5) = RNP
Sheets("G-DRIVE").Select
Range(Cells(RNC, 1), ActiveCell.Offset(0, 24)).Select
Selection.Delete Shift:=xlUp
RNC = RNC - 1
Return
MOVEFILE:
FCS$ = Cells(RNC, 15) & Cells(RNC, 17)
FPS$ = Cells(RNC, 16) & Cells(RNC, 17)
FTS$ = "C\USERS\" & Cells(1, 19) & "\DOCUMENTS\VAULT\PROJECTS\*" & Cells(RNC, 17) & "/S"
Do While Dir(FTS$) <> ""
MSGF = MsgBox("filename " + FPS$ + " exists.Rename?", vbYesNo)
If MSGF = vbYes Then FPS$ = FPS$ + "_1"
If MSGF = vbYes Then FTS$ = FTS$ + "_1"
If MSGF = vbNo Then MSG = MsgBox("Copy failed. Try again?", vbYesNo)
If MSGF = vbNo Then If MSG = vbNo Then MsgBox ("File Skipped")
If MSGF = vbNo Then If MSG = vbNo Then Return
Loop
FileCopy FCS$, FPS$
If Dir(FPS$) <> "" Then
MSGD = MsgBox("COPY SUCCESS! ERASE " + FCS$ + "?", vbYesNo)
If MSGD = vbYes Then Kill (FCS$)
End If
Return
ENDTHISSUB:
End Sub

[code]

**mrice** · 06-15-2015, 03:28 PM

Maybe this will help

'This macro uses the technique of recursion to examine the contents of a folder structure no matter how complex it is.

Sub Extract()
Dim Filename As Variant
' Set up the empty spreadsheet
Cells.Clear
Cells(1, 1) = "Folder"
Cells(1, 2) = "File"
Cells(1, 3) = "Size"
Cells(1, 4) = "Name"

'Use the GetOpenFilename function to get a full path description of a typical file
Filename = Application.GetOpenFilename()
If Filename = False Then Exit Sub
'The GetSubDirectories subroutine is called recursively using the name of the parent folder as the single argument.
Call GetSubDirectories(Left(Filename, Len(Filename) - Len(Dir(Filename)) - 1))


Columns.AutoFit
End Sub

Sub GetSubDirectories(folderspec)
Dim fs As Object, f As Object, s As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Call GetFiles(f.Path)
For Each SubFolder In f.subfolders
    GetSubDirectories (f.Path & "\" & SubFolder.Name) ' This is a recursive call
Next SubFolder
End Sub

Sub GetFiles(folderspec)
Dim fs As Object, f As Object, s As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)

For Each File In f.Files
    On Error Resume Next
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = folderspec ' next available cell in column 1
    Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).Value = folderspec & "\" & File.Name
    Cells(Rows.Count, 1).End(xlUp).Offset(0, 2).Value = File.Size
    Cells(Rows.Count, 1).End(xlUp).Offset(0, 3).Value = File.Name
    On Error GoTo 0
Next File
End Sub

When prompted, select a file in your top level folder - if there isn't one then create one as an anchor.