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
*********************************************************************