unknownymous
Board Regular
- Joined
- Sep 19, 2017
- Messages
- 249
- Office Version
- 2016
- Platform
- Windows
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.
<tbody>
</tbody>
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
<tbody>
</tbody>
Reference (Sheet 2)
Headers: Row 1
<tbody>
</tbody>
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.
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.
x | OldFileName (Cell B14) | I | II | III | New Name | Algebra | 0619 | |
0001.xlsx | Ben_Math_0619.xlsx | |||||||
0002.txt | ||||||||
0003.xlsx | ||||||||
0004.doc | ||||||||
<tbody>
</tbody>
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
x | OldName | I | II | III | New Name(Final) | (Insert Subject Here) Example: Algebra | (Insert Date) Example: 0619 | |
0001.xlsx | Ben_Math_0619.xlsx | |||||||
0002.txt | Sean_Math_0619.txt | |||||||
0003.xlsx | May_Math_0619.xlsx | |||||||
0004.doc | Beth_Math_0619.doc | |||||||
<tbody>
</tbody>
Reference (Sheet 2)
Headers: Row 1
Name (Old) | Name (ChangeTo) | Subject | Subject (ChangeTo) | ||
0001 | Ben | Math | Math | ||
0002 | Sean | Algebra | Math | ||
0003 | May | Trigonometry | Math | ||
0004 | Beth | Physics | Science |
<tbody>
</tbody>
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.