Excel VBA: rename files v2

Try this

Option Explicit

Sub Rename_Files()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
Dim Ans As VbMsgBoxResult

Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A and new_files_names are reported in column B." & _
vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
If Ans = vbNo Then Exit Sub

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then
        xDir = .SelectedItems(1) & Application.PathSeparator & "Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
        xFile = Dir(xDir & Application.PathSeparator & "*")
        Do Until xFile = ""
            xRow = 0
            On Error Resume Next
            xRow = Application.Match(xFile, Range("A:A"), 0)
            If xRow > 0 Then
                Name xDir & Application.PathSeparator & xFile As _
                xDir & Application.PathSeparator & Cells(xRow, "B").Value
            End If
            xFile = Dir
        Loop
    End If
End With
End Sub

Select allOpen in new window

I would like to add the following requirement:
Perform the rename in a new folder located in the same folder in which are located files:
Name of the folder: Rename- & Format(Now, "yyyy-mm-dd-hh-mm")

Can you clarify further?  The files currently exist in some folder, and you want them renamed into a new sub-folder with the date stamp?  Are the files to be copied and given the new name, or moved and renamed in the subfolder?

---

»bp

Good point Bill.
Possible to add a msgbox: "Do you want to keep source files rename or do you want to delete? If you click on yes files will be kept else they will be deleted.
@Roy: possible to add this point?
Thank you very much for your help.

I haven't tested this so try with some dummy files

Option Explicit

Sub Rename_Files()
    Dim xDir As String
    Dim xFile As String
    Dim xRow As Long
    Dim Ans As VbMsgBoxResult
    Dim bDelete As Boolean

    Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A and new_files_names are reported in column B." & _
                 vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbNo Then Exit Sub

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            xDir = .SelectedItems(1) & Application.PathSeparator & "Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
            xFile = Dir(xDir & Application.PathSeparator & "*")
            Ans = MsgBox("Do you want to delete the original files?." & _
                         vbNewLine & "If so, please click on Yes else click on No.", vbQuestion + vbYesNo, "Confirm Please!")
            If Ans = vbYes Then bDelete = True

            Do Until xFile = ""
                xRow = 0
                On Error Resume Next
                xRow = Application.Match(xFile, Range("A:A"), 0)
                If xRow > 0 Then
                    Name xDir & Application.PathSeparator & xFile As _
                         xDir & Application.PathSeparator & Cells(xRow, "B").Value
                End If
                If bDelete Then
                    On Error Resume Next
                    Kill xFile
                    On Error GoTo 0
                End If
                xFile = Dir
            Loop
        End If
    End With
End Sub

Select allOpen in new window

Hello Roy,

I tested however I don't get the rename actions.
I thought it was due to the fact that xDir should be created previously the rename:
All the files to rename exist in download folder.
Here is my revised proposal with xDir folder creation. I also added at the end a command to open folder which should contains the rename files.

Sub Rename_Files_In_Date_Stamp_Folder()
    Dim xDir As String
    Dim xFile As String
    Dim xRow As Long
    Dim Ans As VbMsgBoxResult
    Dim bDelete As Boolean

    Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A and new_files_names are reported in column B." & _
                 vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbNo Then Exit Sub

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            xDir = .SelectedItems(1) & Application.PathSeparator & "Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
            If Dir(xDir, vbDirectory) <> vbNullString Then
            MkDir xDir
            End If
            xFile = Dir(xDir & Application.PathSeparator & "*")
            Ans = MsgBox("Do you want to delete the original files?." & _
                         vbNewLine & "If so, please click on Yes else click on No.", vbQuestion + vbYesNo, "Confirm Please!")
            If Ans = vbYes Then bDelete = True

            Do Until xFile = ""
                xRow = 0
                On Error Resume Next
                xRow = Application.Match(xFile, Range("A:A"), 0)
                If xRow > 0 Then
                    Name xDir & Application.PathSeparator & xFile As _
                         xDir & Application.PathSeparator & Cells(xRow, "B").Value
                End If
                If bDelete Then
                    On Error Resume Next
                    Kill xFile
                    On Error GoTo 0
                End If
                xFile = Dir
            Loop
        End If
        MsgBox xDir & Application.PathSeparator & xFile
    End With
    Shell "C:\WINDOWS\explorer.exe """ & xDir & "", vbNormalFocus
End Sub

Select allOpen in new window

Thank you in advance for your help.

I presumed that the original code was working and you just wanted the amendments

I reviewed the procedure and the following works for me.
Could you please help me to add the flag in case we want to remove files from SourceFolder?
Thank you very much for your help

Sub Rename_Files_In_Date_Stamp_Folder()
    Dim Ans As VbMsgBoxResult
    Dim Ws As Worksheet
    Dim i As Long
    Dim LRow As Long
    Dim FSO As Object

Set Ws = ActiveSheet
Set FSO = CreateObject("Scripting.FileSystemObject")
LRow = Ws.Range("A" & Rows.Count).End(xlUp).Row

    Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A (initial range A2 and new_files_names are reported in column B (initial range B2)." & _
                 vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbNo Then Exit Sub

    With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then
    SourceFolder = .SelectedItems(1) & Application.PathSeparator
    TargetFolder = .SelectedItems(1) & Application.PathSeparator & "Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
    MkDir TargetFolder
    MsgBox TargetFolder & " has been created"
    End If
    End With
    For i = 2 To LRow
    FileName = Ws.Range("A" & i).Value
    TargetFileName = Ws.Range("B" & i).Value
        'Check if Source file exist
        If Not FileExist(SourceFolder & FileName) Then
        MsgBox "File: " & SourceFolder & FileName & " doesn't exist, operation has been aborted"
        Exit Sub
        End If
        'Add backslash in SourceFolder and TargetFolder
        If Right(SourceFolder, 1) <> "\" Then
        TargetFolder = TargetFolder & "\"
        End If
        If Right(TargetFolder, 1) <> "\" Then
        TargetFolder = TargetFolder & "\"
        End If
    'Copy and Rename
    FSO.CopyFile SourceFolder & FileName, TargetFolder
    Name TargetFolder & FileName As TargetFolder & TargetFileName
    MsgBox (" File: " & SourceFolder & FileName & " has rename: " & TargetFolder & TargetFileName)
    Next i
    Shell "C:\WINDOWS\explorer.exe """" & TargetFolder & "", vbNormalFocus"
End Sub

Select allOpen in new window

You haven't declared all your variables and I assume you have a Function to check if the file exists called FileExist.

Again, test this

Sub Rename_Files_In_Date_Stamp_Folder()
    Dim Ans As VbMsgBoxResult
    Dim Ws As Worksheet
    Dim i As Long
    Dim LRow As Long
    Dim FSO As Object
    Dim bDelete As Boolean

    Set Ws = ActiveSheet
    Set FSO = CreateObject("Scripting.FileSystemObject")
    LRow = Ws.Range("A" & Rows.Count).End(xlUp).Row

    Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A (initial range A2 and new_files_names are reported in column B (initial range B2)." & _
                 vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbNo Then Exit Sub

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            SourceFolder = .SelectedItems(1) & Application.PathSeparator
            TargetFolder = .SelectedItems(1) & Application.PathSeparator & "Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
            MkDir TargetFolder
            MsgBox TargetFolder & " has been created"
        End If
    End With
    
      Ans = MsgBox("Do you want to delete the original files?." & _
                         vbNewLine & "If so, please click on Yes else click on No.", vbQuestion + vbYesNo, "Confirm Please!")
            If Ans = vbYes Then bDelete = True
    
    For i = 2 To LRow
        Filename = Ws.Range("A" & i).Value
        TargetFileName = Ws.Range("B" & i).Value
        'Check if Source file exist
        If Not FileExist(SourceFolder & Filename) Then
            MsgBox "File: " & SourceFolder & Filename & " doesn't exist, operation has been aborted"
            Exit Sub
        End If
        'Add backslash in SourceFolder and TargetFolder
        If Right(SourceFolder, 1) <> "\" Then TargetFolder = TargetFolder & "\"
        If Right(TargetFolder, 1) <> "\" Then TargetFolder = TargetFolder & "\"
        'Copy and Rename
        
        FSO.CopyFile SourceFolder & Filename, TargetFolder
        Name TargetFolder & Filename As TargetFolder & TargetFileName
        MsgBox (" File: " & SourceFolder & Filename & " has rename: " & TargetFolder & TargetFileName)
        
           If bDelete Then
                    On Error Resume Next
                    Kill SourceFolder & Filename
                    On Error GoTo 0
                End If
    Next i
    Shell "C:\WINDOWS\explorer.exe """" & TargetFolder & "", vbNormalFocus"
End Sub

Select allOpen in new window

If you only have the original files in SourceFolder you could simply delete the folder

Option Explicit

Sub Rename_Files_In_Date_Stamp_Folder()
    Dim Ans As VbMsgBoxResult
    Dim Ws As Worksheet
    Dim i As Long, LRow As Long
    Dim FSO As Object
    Dim TargetFolder As String, SourceFolder As String, FileName As String, TargetFilename As String
    Dim bDelete As Boolean

    Set Ws = ActiveSheet
    Set FSO = CreateObject("Scripting.FileSystemObject")
    LRow = Ws.Range("A" & Rows.Count).End(xlUp).Row

    Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A (initial range A2 and new_files_names are reported in column B (initial range B2)." & _
                 vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbNo Then Exit Sub

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            SourceFolder = .SelectedItems(1) & Application.PathSeparator
            TargetFolder = .SelectedItems(1) & Application.PathSeparator & "Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
            MkDir TargetFolder
            MsgBox TargetFolder & " has been created"
        End If
    End With

    Ans = MsgBox("Do you want to delete the original files?." & _
                 vbNewLine & "If so, please click on Yes else click on No.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbYes Then bDelete = True

    For i = 2 To LRow
        FileName = Ws.Range("A" & i).Value
        TargetFilename = Ws.Range("B" & i).Value
        'Check if Source file exist
        If Not FileExist(SourceFolder & FileName) Then
            MsgBox "File: " & SourceFolder & FileName & " doesn't exist, operation has been aborted"
            Exit Sub
        End If
        'Add backslash in SourceFolder and TargetFolder
        If Right(SourceFolder, 1) <> "\" Then TargetFolder = TargetFolder & "\"
        If Right(TargetFolder, 1) <> "\" Then TargetFolder = TargetFolder & "\"
        'Copy and Rename

        FSO.CopyFile SourceFolder & FileName, TargetFolder
        Name TargetFolder & FileName As TargetFolder & TargetFilename
        MsgBox (" File: " & SourceFolder & FileName & " has rename: " & TargetFolder & TargetFilename)

    Next i

    If bDelete Then
        On Error Resume Next
        Kill SourceFolder & "*.*"   ''/// delete all files in the folder
        RmDir SourceFolder  ''/// delete folder
        On Error GoTo 0
    End If

    Shell "C:\WINDOWS\explorer.exe """" & TargetFolder & "", vbNormalFocus"
End Sub

Select allOpen in new window

@LD16,

I have a question.  Do the file names in column A and B contain any wildcards, or are they just actual file names?  If they are actual file names then I think you are approaching this the hard way, and will propose a simpler solution.

---

»bp

LD16, using the KIll command is irreversible. You might be interested in Chip Pearson's code to send items to the Recycle Bin

Recycling A File Or Folder

@Bill: files names dont contain will card. In those columns, just files name should be reported.
@Roy: thank you for your feedback I will test it soon.

Okay, here is how I would approach it using the filesystem object.  A few notes:

• I assumes the old and new file names start in row 1 of the current sheet when the macro is run.
• I update column C next to each set of names with a status (Copied, Moved, Missing).
• Rather than read all files in the selected folder and match to the list in column A, I process each row of column A and look for that specific file.
• I presented an option allowing removal of the existing file after it is moved and renamed to the dated destination folder, or keeping it.

Option Explicit

Sub Rename_Files()
    ' Local variables
    Dim MsgText As String
    Dim MsgAns As VbMsgBoxResult
    Dim DeleteOld As Boolean
    Dim FolderPicker As FileDialog
    Dim FSO As FileSystemObject
    Dim LastRow As Integer
    Dim i As Integer
    Dim BaseDir As String
    Dim DestDir As String
    Dim OldPath As String
    Dim NewPath As String

    ' Confirmation to proceed
    MsgText = "Before running this procedure, please check that old_files_names are reported in column A and new_files_names are reported in column B."
    MsgText = MsgText & vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename."
    MsgAns = MsgBox(MsgText, vbQuestion + vbYesNo, "Confirm Please!")
    If MsgAns = vbNo Then Exit Sub

    ' Ask if moving files, or just copying
    MsgText = "Delete old files after renaming to new folder?"
    MsgAns = MsgBox(MsgText, vbQuestion + vbYesNo, "Delete old files?")
    If MsgAns = vbNo Then
        DeleteOld = False
    Else
        DeleteOld = True
    End If

    ' Create filesystem object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Prompt for base folder to work in (exit if none selected)
    Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
    FolderPicker.AllowMultiSelect = False
    If FolderPicker.Show <> -1 Then Exit Sub
    BaseDir = FolderPicker.SelectedItems(1)
    
    ' Create new sub-folder with current datetime to place renamed files in
    DestDir = BaseDir & "\Rename-" & Format(Now, "yyyy-mm-dd-hh-mm")
    If Not FSO.FolderExists(DestDir) Then
        FSO.CreateFolder DestDir
    End If
    
    ' Process all rows in columns A and B (oldname, newname)
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To LastRow
        ' Skip any blank rows
        If Range("A" & i).Value <> "" Then
        
            ' Build full path for old and new file
            OldPath = BaseDir & "\" & Range("A" & i).Value
            NewPath = DestDir & "\" & Range("B" & i).Value
            
            ' Make sure old file exists
            If FSO.FileExists(OldPath) Then
                ' Copy or Move based on user option selected
                If DeleteOld Then
                    FSO.MoveFile OldPath, NewPath
                    Range("C" & i).Value = "Moved"
                Else
                    FSO.CopyFile OldPath, NewPath, False
                    Range("C" & i).Value = "Copied"
                End If
            Else
                Range("C" & i).Value = "Missing"
            End If
        
        End If
    Next
End Sub

Select allOpen in new window

EE29140295.xlsm

---

»bp

Thank you very much Bill. I will test it this weekend. Possible to add a global error handling condition. If error go to exit sub with a global message: "Operation has been aborted. Please check that information has been properly reported (ie: column a: old name, column b: new name)?"
Thank you very much.

We could add a bit of error catching, although I try to act on them as they come up rather than in a global catch all approach.  VBA doesn't have the robust error trapping that things like C# do unfortunately...

---

»bp

Tested and it works! Thank you again for your help!