VBA Rename File Names

[unknownymous]

Hi Team,

I was looking for some codes in bulk renaming of filenames and found below a helpful one (see current codes). I have a separate macro that can generate the file names (refer to B14). However, for me to change the filename, I do it manually. Example: Replace "." with "_Math_0619" and look for the equivalent name for the account code.


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]x [/TD]
[TD]OldFileName (Cell B14)[/TD]
[TD]I[/TD]
[TD]II[/TD]
[TD]III[/TD]
[TD]New Name[/TD]
[TD]Algebra[/TD]
[TD]0619[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0001.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Ben_Math_0619.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0002.txt[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0003.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0004.doc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Current Codes:

Sub RenameFiles()


Dim MyPath As String


ActiveSheet.Unprotect
Application.ScreenUpdating = False
Range("Filelist").Offset(1, 0).Select
RowCounter = 0
Unchanged = 0
If ActiveCell.Value = "" Then
MsgBox "No files detected", vbInformation, "Rename files"
Exit Sub
End If
MyPath = Range("Path").Value
If MyPath = "" Then
Application.ScreenUpdating = True
MsgBox "No Path specified", vbInformation, "Rename files"
Exit Sub
End If
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""
On Error GoTo BadFile
Do
If ActiveCell.Offset(RowCounter, 0).Interior.ColorIndex <> RenamedColour Then
NextFile = MyPath & ActiveCell.Offset(RowCounter, 0)
ChangeTo = MyPath & ActiveCell.Offset(RowCounter, 4)
RowCounter = RowCounter + 1
If NextFile = ChangeTo Then
Range("B" & RowCounter + Range("Filelist").Row & ":F" & RowCounter + Range("Filelist").Row).Interior.ColorIndex = UnchangedColour
Range("E" & RowCounter + Range("Filelist").Row).Value = "U"
Unchanged = Unchanged + 1
Else
Name NextFile As ChangeTo
Range("B" & RowCounter + Range("Filelist").Row & ":F" & RowCounter + Range("Filelist").Row).Interior.ColorIndex = RenamedColour
Range("E" & RowCounter + Range("Filelist").Row).Value = "R"
End If
Else
RowCounter = RowCounter + 1
End If
Loop Until ActiveCell.Offset(RowCounter, 0).Value = ""
Application.ScreenUpdating = True
MsgBox RowCounter - Unchanged & " files renamed" & Chr(13) & Unchanged & " files unchanged", vbInformation, "Rename files"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
Exit Sub
BadFile:
Range("B" & RowCounter + Range("Filelist").Row & ":F" & RowCounter + Range("Filelist").Row).Interior.ColorIndex = ProblemColour
Range("E" & RowCounter + Range("Filelist").Row).Value = "P"
Range("Filelist").Offset(RowCounter, 0).Select
Application.ScreenUpdating = True
MsgBox "Problem with file..." & Chr(13) & Chr(13) & NextFile & Chr(13) & Chr(13) & "Error=" & Err.Description, vbCritical, "Rename files"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
End Sub


==== ===========

Can you help me tweak the codes about to get below results (New Name Final)?

=================

RESULTS:

Main (Sheet 1)

Headers: Row 13

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]x[/TD]
[TD]OldName[/TD]
[TD]I[/TD]
[TD]II[/TD]
[TD]III[/TD]
[TD]New Name(Final)[/TD]
[TD](Insert Subject Here) Example: Algebra[/TD]
[TD](Insert Date) Example: 0619[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0001.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Ben_Math_0619.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0002.txt[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Sean_Math_0619.txt[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0003.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]May_Math_0619.xlsx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]0004.doc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Beth_Math_0619.doc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Reference (Sheet 2)

Headers: Row 1

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name (Old) [/TD]
[TD]Name (ChangeTo)[/TD]
[TD][/TD]
[TD]Subject[/TD]
[TD]Subject (ChangeTo)[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]0001[/TD]
[TD]Ben[/TD]
[TD][/TD]
[TD]Math[/TD]
[TD]Math[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]0002[/TD]
[TD]Sean[/TD]
[TD][/TD]
[TD]Algebra[/TD]
[TD]Math[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]0003[/TD]
[TD]May[/TD]
[TD][/TD]
[TD]Trigonometry[/TD]
[TD]Math[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]0004[/TD]
[TD]Beth[/TD]
[TD][/TD]
[TD]Physics[/TD]
[TD]Science[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Note:

1.) I need to lookup for the account number (Old Name) to second tab to get the equivalent name
3.) I need to lookup up for the subject to get the equivalent specific subject
4.) Add the date stated in H13


Any help will be much appreciated.