Rename files in the end name based on use inputbox

Hello,
I have code to populate files names in column B, what I want new procedure to combine with original code . so the new procedure should use dialog inputbox first write specific file name after click ok show new inputbox to write word in inputbox after that should rename file name in column A and rename file name within folder or subfolder is existed in selected folder.
ex1:
1- first step inputbox I write just number as in B2=25,700
2-second step inputbox I write word "DON" then the new file name
in A2=INVOICE 25,700 DONE
3- third step rename file in folders and subfoders for selected folder.


ex2:
1- first step inputbox I write just number as in B3=25,240
2-second step inputbox I write word "CURRENT" then the new file name in A3=INVOICE 25,240 CURRENT
the words should add in the end of numbers.
3- third step rename file in folders and subfoders for selected folder.
important: could be there are files contains the same name but within subfolders so should rename first and when run again then should rename next (don't rename the same files names at once)
thanks

1 and 2 step is somewhat clear.
how about step 3? do you need to rename filename in column B with filename in Column A on same row?

Quote:

---

do you need to rename filename in column B with filename in Column A on same row?

---

rename in column A and keep old name in column B.

here try this.

Thanks for code , but I would fix repeating same names files within subfolders as I said

Quote:

---

important: could be there are files contains the same name but within subfolders so should rename first and when run again then should rename next (don't rename the same files names at once)

---

I should rename or change file have already named for the same files names should be one by one every time run the form , but the code will rename at once for all of same files names and I don't want it.
also if there is possible to show new file name in column A for adjacent cell for column B instead off add new rows.

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

Code:

---

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

---

this will only rename 1 file.
if you have multiple file with same filename on subfolder, you need to run again the Userform.

Quote:

---

Originally Posted by Kalil

ex1:
1- first step inputbox I write just number as in B2=25,700
2-second step inputbox I write word "DON" then the new file name
in A2=INVOICE 25,700 DONE
3- third step rename file in folders and subfoders for selected folder.

---

Code:

---

Sub test()
    Dim myDir$, s$, suf$, myList(), e, x
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = "" Then Exit Sub
    Do
        s = InputBox("Enter amount")
        If s = "" Then Exit Do
        suf = InputBox("Enter word")
        If suf = "" Then Exit Do
        x = SearchFiles(myDir & "\", "*" & s & "*.xls*", 0, myList())
        If IsArray(x) Then
            For Each e In x
                If Not e Like "* " & suf & ".xls*" Then
                    If Not IsFileOpen(e) Then
                        Name e As Application.Replace(e, InStrRev(e, "."), 0, " " & suf & ".")
                    Else
                        MsgBox e & String(2, vbLf) & " Is Currently in USE.", vbCritical
                    End If
                End If
            Next
        Else
            MsgBox "Not found"
        End If
        If MsgBox("Do you want to continue?", vbQuestion + vbYesNo) <> vbYes Then Exit Do
    Loop
End Sub


Function SearchFiles(myDir$, myFileName$, n&, myList)
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.GetFolder(myDir).Files
        If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
        * (myFile.Name Like myFileName) Then
            n = n + 1
            ReDim Preserve myList(1 To n)
            myList(n) = myDir & myFile.Name
        End If
    Next
    For Each myFolder In fso.GetFolder(myDir).SubFolders
        SearchFiles = SearchFiles(myFolder.Path & "\", myFileName, n, myList)
    Next
    If n Then
        SearchFiles = myList
    Else
        SearchFiles = CVErr(2024)
    End If
End Function


Function IsFileOpen(ByVal fName$) As Boolean
    Dim ff&, errNum&
    On Error Resume Next
    ff = FreeFile
    Open fName For Input Lock Read As #ff
    Close ff
    errNum = Err
    On Error GoTo 0
    IsFileOpen = (errNum <> 0)
End Function

---

Aussiebear

Quote:

---

If the above is correct then perhaps this might suffice

---

this is exactly what I look for, but unfortunately your code doesn't work well
for some reason will rename files and ignore others and will skip files in main folder and rename in subfolder .
strangely when try adding words will show me message not found in the specified folder or subfolders!!:doh:
despite the original cod in OP will brings files in column B,C so why show me this message?!:(

Quote:

---

this will only rename 1 file.

---

but this is will start from subfolder and ignore main folder arnelgp . I suppose starting from main folder one file by one until and move next subfolder and so on .and why start from lastrow when add new file ,why not put on adjacent cell for old name in column B?!

Great work ,jindon!
but I need to fix repeating for the same files names.
I would start when renaming from main folder and move next subfolder one file by one and so on
not renaming at once for same files names within folders and subfolders as your code does it.
also I would show new names files in column A for adjacent cells in column B after renaming within folders and subfolders.

Quote:

---

Originally Posted by Kalil

but this is will start from subfolder and ignore main folder arnelgp . I suppose starting from main folder one file by one until and move next subfolder and so on .and why start from lastrow when add new file ,why not put on adjacent cell for old name in column B?!

---

then select the main folder.

Code:

---

Sub test()
    Dim myDir$, s$, suf$, x, n&
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = "" Then Exit Sub
    Do
        s = InputBox("Enter amount")
        If s = "" Then Exit Do
        suf = InputBox("Enter word")
        If suf = "" Then Exit Do
        x = SearchFiles(myDir & "\", "*" & s & ".xls*")
        If x <> "" Then
            n = n + IIf(n, 1, 2)
            Cells(n, 2) = CreateObject("Scripting.FileSystemObject").GetBaseName(x)
            Cells(n, 3) = x
            If Not IsFileOpen(x) Then
                Name x As Application.Replace(x, InStrRev(x, "."), 0, " " & suf)
                Cells(n, 1) = Cells(n, 2) & " " & suf
            Else
                Cells(n, 4) = "Currently in USE " & Format(Now, "yyyy/mm/dd hh:mm:ss")
            End If
        Else
            MsgBox "Not found"
        End If
        If MsgBox("Do you want to continue?", vbQuestion + vbYesNo) <> vbYes Then Exit Do
    Loop
End Sub


Function SearchFiles$(myDir$, myFileName$)
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.GetFolder(myDir).Files
        If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
        * (myFile.Name Like myFileName) Then
            SearchFiles$ = myDir & myFile.Name
            Exit Function
        End If
    Next
    For Each myFolder In fso.GetFolder(myDir).SubFolders
        SearchFiles = SearchFiles(myFolder.Path & "\", myFileName)
    Next
End Function


Function IsFileOpen(ByVal fName$) As Boolean
    Dim ff&, errNum&
    On Error Resume Next
    ff = FreeFile
    Open fName For Input Lock Read As #ff
    Close ff
    errNum = Err
    On Error GoTo 0
    IsFileOpen = (errNum <> 0)
End Function

---

Quote:

---

then select the main folder.

---

this is what I really did it .:wot

thanks jindon for your effort.
but this is not I want !
if I have in column B:C like this
86,000.00 C:\Users\pc\KLL\main\86,000.00.xlsm
INVOICE 87,000.00 C:\Users\pc\KLL\main\DTA\87,000.00.xlsm
so in column A should be when write done
then
will be
86,000.00 done. 86,000.00 C:\Users\pc\KLL\main\86,000.00.xlsm
and when write current then will be
86,000.00 done. 86,000.00 C:\Users\pc\KLL\main\86,000.00.xlsm
INVOICE 87,000.00 current 87,000.00 C:\Users\pc\KLL\main\DTA\87,000.00.xlsm
also when I would change files have already written
ex:
86,000.00 done. 86,000.00 C:\Users\pc\KLL\main\86,000.00.xlsm
when write 86,000.00 done and I would change to current then should change from done to current like this
86,000.00 current. 86,000.00 C:\Users\pc\KLL\main\86,000.00.xlsm
also I would when rename should select cell in column B or C if I write then will rename file based on selected cell if I don't write anything then will skip and move next cell to select and so on .
last thing I don't want dot (.) when I write word.

I don't understand what you are talking about, so wait for someone else.

the problem will be for same files names .:banghead:

I admit the case is really complicated .
ok guys
here are some pictures
when I have many same files names then should move and active cell by select when click input box without write amounts
example :
if I write amount 12,000.00 as in B2 and write DONE will rename for B2 in folders or subfolders as in PIC 1,2 ,3 , but the question is how avoid B2
and I would rename file B5 as pic 4,5 also I would change amount contains done word to current word as in pic 6,7 should change in A5 from done to current .
and as I mentioned many times every new name file should be in adjacent in column b like picture 8,9

here rest of pictures 4,5

here is pic 6,7

pictur 8,9