Copy and rename files without overwriting files

[miguel78]

Hello,

I need some help to adjust this code found on the internet.

I would like that whenever I run the code, new files on the destination folder are never overwritten. The solution seems easy, but I tried a lot and I'm inexperienced in VBA. Please help me.

File attached.

Thank you.

Sub gerafiles()
Dim src As String, dst As String, fl As String
Dim rfl As String
Dim lngMyRow As Long
Dim lngLastRow As Long

Application.ScreenUpdating = True

lngLastRow = Range("B:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
'Source directory
src = Range("B3")
'Destination directory
dst = Range("D3")
For lngMyRow = 6 To lngLastRow
'File name
fl = Range("B" & lngMyRow)
'Rename file
rfl = Range("D" & lngMyRow)
On Error Resume Next
FileCopy src & "\" & fl, dst & "\" & rfl

On Error GoTo 0
Next lngMyRow

Application.ScreenUpdating = True

MsgBox "OK"

End Sub17844

[Leith Ross]

Hello miguel78,

Try this macro. The source file names start in cell "B3". The new file names start in cell "D3". You can change these cells to match your worksheet layout.



Sub RenameFiles()


Dim Cell As Range
Dim DstRng As Range
Dim RngEnd As Range
Dim SrcRng As Range
Dim Wks As Worksheet


Set wks = ActiveSheet


' Starting cell of the Old File Names Range (Source Range).
Set SrcRng = Wks.Range("B3")


' Starting cell of the New File Names Range (Destination Range).
Set DstRng = Wks.Range("D3")


' Find the last entry in the Source Range.
Set RngEnd = Wks.Cells(Rows.Count, SrcRng.Column).End(xlUp)


' Check the Source Range has data.
If RngEnd.Row < SrcRng.Row Then Exit sub


For Each Cell In Wks.Range(SrcRng, RngEnd)
' Rename the file.
Name Cell As DstRng


' Get the next destination cell
Set DstRng = DstRng.Offset(1, 0)
Next Cell


End Sub