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)
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
I would like to add the following requirement: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?
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")
ASKER
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
ASKER
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
ASKER
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
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
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
ASKER
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
ASKER
ASKER
Microsoft Excel topics include formulas, formatting, VBA macros and user-defined functions, and everything else related to the spreadsheet user interface, including error messages.
TRUSTED BY
Open in new window