Copying Multiple Paths/Files/Folders to New Paths and Rename with VBA

[Jambi46n2]

Below is existing code from Ron de Bruin.
It works great for one path at a time, however I need it to work for multiple paths.
My screen shot below is the workbook I'm using and can't seem to get it passed one row with coping files and folders.
Additionally can I add a naming convention to every file copied as listed in F2 and F3?

Is this possible?

Thanks in advance!

Sub Copy_Folder()
'Copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.

If MsgBox("Copy Files to New Folder?", vbYesNo) = vbNo Then Exit Sub

    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = [From_Path]  '<< Change
    ToPath = [To_Path]    '<< Change

    'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set fso = CreateObject("scripting.filesystemobject")

    If fso.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
   
    fso.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "Files Have Been Copied to New Folder"

End Sub

 

[sijpie]

Option Explicit

Sub CopyFilesToFolders()
    Dim vFrom As Variant, vTo As Variant
    Dim lR As Long, UB As Long
    Dim bErrFlag As Boolean
    
    If MsgBox("Copy Files to New Folders?", vbYesNo) = vbNo Then Exit Sub
    
    'load the from and to lists into two arrays
    vFrom = Range("B1").CurrentRegion.Value
    UB = UBound(vFrom, 1)
    
    vTo = Range("D1").Resize(UB, 1)
    
    'now go through each of the folder names in the vFrom array and copy the files to the relevant folder name in the vTo array
    For lR = 2 To UB    'skip the header
    'quick check if there are paths in both from and to
    If Len(vFrom(lR, 1)) And Len(vTo(lR, 1)) Then
        'copy the folders. The copy function will return False on an error
        If Copy_Folder(vFrom(lR, 1), vTo(lR, 1)) Then
            vFrom(lR, 1) = ""
        Else
            bErrFlag = True
        End If
    Else
        bErrFlag = True
    End If
    
    If bErrFlag Then
        'an error copying has occured. Dump the incomplete processed From folders to a sheet
        Sheets.Add before:=ActiveSheet
        [A1] = "The following folders had problems with the copy:"
        Range("A2").Resize(UB, 1).Value = vFrom
    Else
        MsgBox "Files Have Been Copied to New Folder"

    End If
End Sub

Function Copy_Folder(sFromFolder As String, sToFolder As String) As Boolean
'Copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.


    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = sFromFolder
    ToPath = sToFolder

    'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set fso = CreateObject("scripting.filesystemobject")

    If fso.FolderExists(FromPath) = False Then
        Copy_Folder = False
        Exit Function
    End If
   
    fso.CopyFolder Source:=FromPath, Destination:=ToPath
    Copy_Folder = True
End Function

 

[Jambi46n2]

Option Explicit

Sub CopyFilesToFolders()
    Dim vFrom As Variant, vTo As Variant
    Dim lR As Long, UB As Long
    Dim bErrFlag As Boolean
   
    If MsgBox("Copy Files to New Folders?", vbYesNo) = vbNo Then Exit Sub
   
    'load the from and to lists into two arrays
    vFrom = Range("B1").CurrentRegion.Value
    UB = UBound(vFrom, 1)
   
    vTo = Range("D1").Resize(UB, 1)
   
    'now go through each of the folder names in the vFrom array and copy the files to the relevant folder name in the vTo array
    For lR = 2 To UB    'skip the header
    'quick check if there are paths in both from and to
    If Len(vFrom(lR, 1)) And Len(vTo(lR, 1)) Then
        'copy the folders. The copy function will return False on an error
        If Copy_Folder(vFrom(lR, 1), vTo(lR, 1)) Then
            vFrom(lR, 1) = ""
        Else
            bErrFlag = True
        End If
    Else
        bErrFlag = True
    End If
   
    If bErrFlag Then
        'an error copying has occured. Dump the incomplete processed From folders to a sheet
        Sheets.Add before:=ActiveSheet
        [A1] = "The following folders had problems with the copy:"
        Range("A2").Resize(UB, 1).Value = vFrom
    Else
        MsgBox "Files Have Been Copied to New Folder"

    End If
End Sub

Function Copy_Folder(sFromFolder As String, sToFolder As String) As Boolean
'Copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.


    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = sFromFolder
    ToPath = sToFolder

    'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set fso = CreateObject("scripting.filesystemobject")

    If fso.FolderExists(FromPath) = False Then
        Copy_Folder = False
        Exit Function
    End If
  
    fso.CopyFolder Source:=FromPath, Destination:=ToPath
    Copy_Folder = True
End Function

Hi sijpie,
Thanks so much for replying.
I tried your code, but received the following error message.
Any thoughts?

 

[sijpie]

Yes, the parameter for the function is declared as string. But I am feeding it a variant. What you need to do is tell it's a string by using the cast to string function cstr().

So change that line to:

 If Copy_Folder(cstr(vFrom(lR, 1)), cstr(vTo(lR, 1))) [\code]