Copy specific list of sub-folders form a main folder

This macro will help to copy a list of specific list of sub folders form a main folder having a many sub folders.


Code:
*********************************************************************
Private Sub CopyFolders()

    Dim FSO As Object
    Dim MyPath As String
    Dim rng As Range
    Dim Cell As Object
    Dim ToPath As String
   
    Set FSO = CreateObject("scripting.filesystemobject")
    MyPath = InputBox("Enter Source Folder")  '<< Change
    ToPath = InputBox("Enter Destination Folder")
    If Right(MyPath, 1) = "\" Then
        MyPath = Left(MyPath, Len(MyPath) - 1)
    End If

    If FSO.FolderExists(MyPath) = False Then
        MsgBox MyPath & " doesn't exist"
        Exit Sub
    End If

Set rng = Application.InputBox(prompt:="Select the cells containg the file names", Title:="Select Range of Cells", Type:=8)
    On Error Resume Next
    For Each Cell In rng
        FSO.CopyFolder MyPath & "\" & Cell.Value, ToPath & "\" & Cell.Value
    Next Cell
End Sub
********************************************************************* 

Copy specific list of files form a group of files to specified folder

This macro will help you to copy specific list of files form a folder containing many files.

Code:
*********************************************************************
Private Sub CopyFiles()
    Dim myfilesystemobject As Object
    Dim myfiles As Object
    Dim myfile As Object
    Dim rng As Range
    Dim Cell As Object
    Dim strDirectory As String
    Dim strDestFolder As String
   
    strDirectory = InputBox("Enter Source Folder")
    strDestFolder = InputBox("Enter Destination Folder")
   
    Set rng = Application.InputBox(prompt:="Select the cells containg the file names", Title:="Select Range of Cells", Type:=8) 'set this to the range of your filtered list
    Set myfilesystemobject = CreateObject("Scripting.FileSystemObject")
    Set myfiles = myfilesystemobject.GetFolder(strDirectory).Files
       
    On Error Resume Next
    For Each Cell In rng
        For Each myfile In myfiles
            If Not IsNull(Cell.Value) Then
                If myfile = strDirectory & "\" & Cell.Value & ".tagged.xml" Then
                    With myfile
                        .Copy strDestFolder & "\" & myfile.Name
                    End With
                Else
                End If
            End If
        Next myfile
    Next Cell
End Sub
*********************************************************************