Macro for copying files from subfolders to another folder according files list

[EgleA]

Hi, I have found a VBA code for copying all files from subfolder to another folder. I think I can use it, but the problem is that I need to copy files according files list, not all files from subfolders. Can anyone help me to change VBA code?

Public Sub CopyFiles_r2()

Dim sPathSource As String, sPathDest As String, sFileSpec As String

sPathSource = "C:\Users\Me\SourceFolder\"
sPathDest = "Z:\DestinationFolderTree\SubFolder\EndpointFolder\"

sFileSpec = "*.xlsx"
'sFileSpec = "*example*2020.xl*"
'sFileSpec = "*.pdf"

Call CopyFiles_FromFolderAndSubFolders(sFileSpec, sPathSource, sPathDest)
End Sub


Public Sub CopyFiles_FromFolderAndSubFolders(ByVal argFileSpec As String, ByVal argSourcePath As String, ByRef argDestinationPath As String)

Dim sPathSource As String, sPathDest As String, sFileSpec As String

Dim FSO As Object
Dim oRoot As Object
Dim oFile As Object
Dim oFolder As Object

sPathSource = argSourcePath
sPathDest = argDestinationPath

If Not Right(sPathDest, 1) = "\" Then sPathDest = sPathDest & "\"
If Right(sPathSource, 1) = "\" Then sPathSource = Left(sPathSource, Len(sPathSource) - 1)

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(sPathSource) And FSO.FolderExists(sPathDest) Then
Set oRoot = FSO.GetFolder(sPathSource)
For Each oFile In oRoot.Files
If LCase(oFile.Name) Like argFileSpec Then
On Error Resume Next
oFile.Copy sPathDest & oFile.Name
On Error GoTo 0
End If
Next oFile
For Each oFolder In oRoot.SubFolders
' == do the same for any folder ==
Call CopyFiles_FromFolderAndSubFolders(argFileSpec, oFolder.Path, sPathDest)
Next oFolder
End If
End Sub

 

[DanteAmor]

Hi and welcome to MrExcel.

I need to copy files according files list

Assuming you have the list on sheet1, starting at cell A2 and going down.
And also assuming that the names have the file extension.

Put all the code in a module

Option Explicit

Dim dic As Object

Public Sub CopyFiles_r2()
  Dim sPathSource As String, sPathDest As String, sFileSpec As String
  Dim c As Range
  
  sPathSource = "C:\Users\Me\SourceFolder\"
  sPathDest = "Z:\DestinationFolderTree\SubFolder\EndpointFolder\"
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  For Each c In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(3))
    dic(c.Value) = Empty
  Next

  sFileSpec = "*.xlsx"
  Call CopyFiles_FromFolderAndSubFolders(sFileSpec, sPathSource, sPathDest)
  Set dic = Nothing
End Sub


Public Sub CopyFiles_FromFolderAndSubFolders(ByVal argFileSpec As String, ByVal argSourcePath As String, ByRef argDestinationPath As String)
  Dim sPathSource As String, sPathDest As String, sFileSpec As String
  Dim FSO As Object, oRoot As Object, oFile As Object, oFolder As Object
  
  sPathSource = argSourcePath
  sPathDest = argDestinationPath
  
  If Not Right(sPathDest, 1) = "\" Then sPathDest = sPathDest & "\"
  If Right(sPathSource, 1) = "\" Then sPathSource = Left(sPathSource, Len(sPathSource) - 1)
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  If FSO.FolderExists(sPathSource) And FSO.FolderExists(sPathDest) Then
    Set oRoot = FSO.GetFolder(sPathSource)
    For Each oFile In oRoot.Files
      If LCase(oFile.Name) Like argFileSpec Then
        If dic.exists(oFile.Name) Then
          On Error Resume Next
          oFile.Copy sPathDest & oFile.Name
          On Error GoTo 0
        End If
      End If
    Next oFile
    For Each oFolder In oRoot.SubFolders
      ' == do the same for any folder ==
      Call CopyFiles_FromFolderAndSubFolders(argFileSpec, oFolder.Path, sPathDest)
    Next oFolder
  End If
End Sub