Copy and Rename Multiple Template Documents to Multiple New Folders

paspuggie48 · Mar 22nd 2016

Dear experts

I have found some code which will help me copy multiple documents from my existing template route folder and copy and rename them into new sub-folders based on the criteria in the cell on my document (which is attached).

http://www.excelforum.com/exce…tiple-files-in-excel.html

Code

Option Explicit
Sub Button1_Click()
    Dim src As String, dst As String, fl As String
    Dim rfl As String
    Dim lngMyRow As Long
    Dim lngLastRow As Long
    
    Application.ScreenUpdating = False
    
    lngLastRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row + 1
    'Source directory
    src = Range("C5")
    'Destination directory
    dst = Range("D5")
    
    For lngMyRow = 2 To lngLastRow
        'File name
        fl = Range("A" & lngMyRow)
        'Rename file
        rfl = Range("B" & lngMyRow)
        On Error Resume Next
            FileCopy src & "\" & fl, dst & "\" & rfl
            If Err.Number <> 0 Then
                MsgBox "Copy error: " & src & "\" & rfl
            End If
        On Error GoTo 0
    Next lngMyRow
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

Display More

It only copies the files to the first sub-folder, obviously because of the lines

Code

src = Range("C5")
    'Destination directory
     dst = Range("D5")

How does one change the code above to loop row by row, until the last folder reference in Column D, on Cell D31?

Cheers
P4

skywriter · Mar 22nd 2016

Re: Copy and Rename Multiple Template Documents to Multiple New Folders

Maybe this. :cool:

Code

Option Explicit
Sub Button1_Click()
    Dim src As String, dst As String, fl As String
    Dim rfl As String
    Dim lngMyRow As Long
    Dim lngLastRow As Long
     
    Application.ScreenUpdating = False
     
    lngLastRow = Range("A:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1


     
    For lngMyRow = 5 To lngLastRow
         'File name
        fl = Range("A" & lngMyRow)
         'Rename file
        rfl = Range("B" & lngMyRow)
             'Source directory
    src = Range("C" & lngMyRow)
     'Destination directory
    dst = Range("D" & lngMyRow)
        On Error Resume Next
        FileCopy src & "\" & fl, dst & "\" & rfl
        If Err.Number <> 0 Then
            MsgBox "Copy error: " & src & "\" & rfl
        End If
        On Error GoTo 0
    Next lngMyRow
     
    Application.ScreenUpdating = True
     
    MsgBox "Done"
     
End Sub

Display More

paspuggie48 · Mar 22nd 2016

Re: Copy and Rename Multiple Template Documents to Multiple New Folders

Spot on Skywriter. I had tried something similar on the lines of what you did but not being excel savvy I was missing

Code

5 To lngLastRow

Many thanks for your help

skywriter · Mar 22nd 2016

Re: Copy and Rename Multiple Template Documents to Multiple New Folders

My pleasure, thanks for the feedback. :cool:

Copy and Rename Multiple Template Documents to Multiple New Folders

Participate now!

Share