Переименовать файлы в разных папках

Sub Rename_File()
    Dim sFileName As String, sNewFileName As String
 
    sFileName = "C:\WWW.xls"    'имя исходного файла
    sNewFileName = "C:\WWW1.xls"    'имя файла для переименования
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
 
    Name sFileName As sNewFileName 'переименовываем файл
 
    MsgBox "Файл переименован", vbInformation, "www.excel-vba.ru"
End Sub

Last = cells(Rows.Count,1).End(xlUp).Row
For I = 1 to Last
  sFileName = Cells(I,1)
  sNewFileName = Cells(I,2)
  Name sFileName As sNewFileName 'переименовываем файл
Next

Sub tt()
Last = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Last
  sFileName = Cells(i, 1)
  sNewFileName = Cells(i, 2)
    FileCopy sFileName, sNewFileName 
    Next
End Sub

Sub proba()
[A1] = "d:\Evgeny\chance.xlsm" 'на примере папок моего компа
Last = Cells(Rows.Count, 1).End(xlUp).Row
For I = 1 To Last
  Call CopyFile(Cells(I, 1), "d:\TMP")
Next
End Sub
 
Sub CopyFile(ByVal Source As String, ByVal NewDir As String)
Dim Sold As String, Snew As String, I As Integer, Last As Integer, Nd As String
Snew = NewDir & "\" & Mid(Source, 4)
Nd = Left(Snew, InStrRev(Snew, "\"))
If Dir(Nd, vbDirectory) = "" Then MkDir Nd
'MsgBox Source & "  " & Snew
FileCopy Source, Destination:=Snew
End Sub

Sub CopyFile(ByVal Source As String, ByVal NewDir As String)
Dim Snew As String, Last As Integer, K, Nd As String
K = 4: Snew = NewDir & Mid(Source, InStrRev(Source, "\") + 1)
Do
  K = InStr(K + 1, Snew, "\")
  If K = 0 Then Exit Do
  Nd = Left(Snew, K)
'  MsgBox "k=" & K & "  " & Nd
  If Dir(Nd, vbDirectory) = "" Then MkDir Nd
Loop
FileCopy Source, Destination:=Snew
End Sub

Sub tt()
Last = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Last
  sFileName = Cells(i, 1)
  sNewFileName = Cells(i, 2)
  MakeSureDirectoryPathExists sNewFileName
    FileCopy sFileName, sNewFileName 'копируем файл
Next
End Sub

Sub CopyFile(ByVal Source As String, ByVal NewDir As String)
Dim Snew As String, Last As Integer, K, Nd As String
K = 4: Snew = NewDir & Mid(Source, InStrRev(Source, "") + 1)
Do
  K = InStr(K + 1, Snew, "")
  If K = 0 Then Exit Do
  Nd = Left(Snew, K)
'  MsgBox "k=" & K & "  " & Nd
  If Dir(Nd, vbDirectory) = "" Then MkDir Nd
Loop
FileCopy Source, Destination:=Snew
End Sub

Sub tt()
Last = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Last
  sFileName = Cells(i, 1)
  sNewFileName = Cells(i, 2)
  Name sFileName As sNewFileName 
Next
End Sub

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub tt()
Last = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Last
  sFileName = Cells(i, 1)
  sNewFileName = Cells(i, 2)
  MakeSureDirectoryPathExists sNewFileName
    FileCopy sFileName, sNewFileName 'копируем файл
Next
End Sub