copy files located in multiple directories that match a partial value

**msheen** · 12-17-2012, 12:07 PM

I want to copy files located in multiple directories (source folders) that match a partial value in column 1 of sheet 1. The code i have works if all the files are in the source folder but will not locate further down in sub directories. Here is my code. Any help would help tremendously.

Sample directory
FROM
E:\P25\1000\
E:\P25\2000\ and so on to E:\P25\100000\
To
C:\temp\Data2\

Sub P25option()
    Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
    Dim c As Range, rPatterns As Range
    Dim bBad As Boolean
    
    sSrcFolder = "E:\P25"
    
    sTgtFolder = "C:\temp\Data2\"


    
    Set rPatterns = Sheet1.Range("A1:A2000").SpecialCells(xlConstants)
    For Each c In rPatterns
        sFilename = Dir(sSrcFolder & "*" & c.Text & "*")
        If sFilename = "" Then
            c.Interior.ColorIndex = 3
            bBad = True
        Else
            While sFilename <> ""
                FileCopy sSrcFolder & sFilename, sTgtFolder & sFilename
                sFilename = Dir()
            Wend
        End If
    Next c
    If bBad Then MsgBox "Some files were not found. " & _
        "These were highlighted for your reference."
End Sub

**JBeaucaire** · 12-17-2012, 04:41 PM

This looks like it should work, untested:

Option Explicit
Dim Found As Boolean, c As Range, rPatterns As Range
Dim sSrcFolder As String, sTgtFolder As String, sFilename As String

Sub P25option()
Dim bBad As Boolean

sSrcFolder = "E:\P25"
sTgtFolder = "C:\temp\Data2\"

    Set rPatterns = Sheet1.Range("A1:A2000").SpecialCells(xlConstants)
    For Each c In rPatterns
        Call LoopController(sSrcFolder, c.Text, False)
        If Not Found Then
            c.Interior.ColorIndex = 3
            bBad = True
        Else
            Found = False
        End If
    Next c

    If bBad Then MsgBox "Some files were not found. " & "These were highlighted for your reference."
End Sub


Sub LoopController(sSrcFolder As String, fname As String, Found As Boolean)
Dim Fldr As Object, FL As Object, SubFldr As Object, f As String

    If Found = True Then Exit Sub
    f = Dir(sSrcFolder & "*" & fname)
    Do While Len(f) >= 0
        FileCopy sSrcFolder & f, sTgtFolder & f
        sFilename = Dir()
        Found = True
    Loop
    If Found = True Then Exit Sub

    Set Fldr = CreateObject("scripting.filesystemobject").Getfolder(sSrcFolder)
    For Each SubFldr In Fldr.SubFolders
        Call LoopController(SubFldr.Path, fname, False)
    Next

End Sub