As I currently understand the OP's request to be this:
Take a filename (or part of a filename) from a cell in column B.
Prompt the user with an input box to enter a word.
Combine the filename from column B with the entered word to create a new filename, and write this new filename in the corresponding cell in column A.
Rename the actual file in the folder (and subfolders) to the new filename.
Handle cases where multiple files with the same name exist in different subfolders, ensuring they are renamed one by one across multiple executions.
If the above is correct then perhaps this might suffice
Option Explicit
' Function to check if a file exists
Private Function FileExists(ByVal fName As String) As Boolean
FileExists = (Dir(fName) <> "")
End Function
' Function to recursively search for files in a folder and its subfolders
Private Function FindFile(ByVal startFolder As String, ByVal fileNameToFind As String, ByRef foundFilePath As String) As Boolean
Dim fso As Object, folder As Object, subFolder As Object, file As Object
Dim found As Boolean
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(startFolder)
' Check files in the current folder
For Each file In folder.Files
If file.Name = fileNameToFind Then
foundFilePath = file.Path
FindFile = True
Exit Function ' Exit the function if found
End If
Next file
' If not found, recursively search subfolders
If Not found Then
For Each subFolder In folder.SubFolders
found = FindFile(subFolder.Path, fileNameToFind, foundFilePath)
If found Then
Exit Function ' Exit the function if found in a subfolder
End If
Next subFolder
End If
End Function
Sub RenameFiles()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fileNamePart As String
Dim newWord As String
Dim newFileName As String
Dim fso As Object
Dim filePath As String
Dim originalFileName As String
Dim fileExtension As String
Dim tempFileName As String
Dim fileWasRenamed As Boolean
Dim startFolder As String ' Added variable to store the starting folder path
' Set the worksheet (change "Sheet1" to your actual sheet name)
Set ws = ThisWorkbook.Sheets("Sheet1")
' Get the last row in column B
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
' Create FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Get the starting folder from the user. Use a constant for testing.
' startFolder = Application.InputBox("Enter the full path of the folder to search:", "Enter Folder Path", , , , , , 8192) 'Type 8192 is for folder selection
startFolder = "C:\Your\Path\Here" ' <--- Replace this with your actual folder path for testing. Remove the hardcoded path and uncomment the InputBox line above for user input.
If startFolder = "False" Then ' Check if the user cancelled the inputbox
MsgBox "Operation cancelled by user.", vbOKOnly, "Cancelled"
Exit Sub
End If
If Not fso.FolderExists(startFolder) Then
MsgBox "Invalid folder path. Please enter a valid folder path.", vbCritical, "Error"
Exit Sub
End If
' Loop through the rows in column B
For i = 2 To lastRow
fileNamePart = Trim(ws.Cells(i, "B").Value)
If fileNamePart <> "" Then
' Get the new word from the user
newWord = Trim(InputBox("Enter the word to add to the filename for " & fileNamePart & ":", "Enter Word"))
If newWord = "" Then
MsgBox "No word entered. Skipping file rename for " & fileNamePart & ".", vbOKOnly, "Skipped"
GoTo NextIteration ' Use a label to jump to the next iteration
End If
' Construct the new filename (add the word to the end of the number)
newFileName = "INVOICE " & fileNamePart & " " & newWord
ws.Cells(i, "A").Value = newFileName ' Update the cell in column A
' Find the file and rename it
originalFileName = fileNamePart 'The original file name is what is in column B
filePath = "" 'Reset
If FindFile(startFolder, originalFileName, filePath) Then ' Find the file.
fileExtension = fso.GetExtensionName(filePath)
If fileExtension <> "" Then
originalFileName = originalFileName & "." & fileExtension ' Add the extension back.
End If
' Construct the *full* new file name with extension.
newFileName = "INVOICE " & fileNamePart & " " & newWord & "." & fileExtension
' Check if the file exists before attempting to rename.
If FileExists(filePath) Then
fileWasRenamed = False
On Error Resume Next 'prevent errors if rename fails
Name filePath As fso.GetParentFolderName(filePath) & "\" & newFileName
On Error GoTo 0
If FileExists(fso.GetParentFolderName(filePath) & "\" & newFileName) Then
fileWasRenamed = True
End If
If fileWasRenamed Then
MsgBox "File '" & originalFileName & "' renamed to '" & newFileName & "'.", vbInformation, "File Renamed"
Else
MsgBox "Failed to rename file '" & originalFileName & "'. It may already be renamed, or the file may be in use.", vbCritical, "Rename Failed"
End If
Else
MsgBox "File '" & originalFileName & "' not found.", vbExclamation, "File Not Found"
End If
Else
MsgBox "File '" & originalFileName & "' not found in the specified folder or subfolders.", vbExclamation, "File Not Found"
End If
End If
NextIteration:
Next i
MsgBox "File renaming process completed.", vbInformation, "Done"
' Clean up
Set fso = Nothing
Set ws = Nothing
End Sub
Reply With Quote
Originally Posted by Kalil
