Try this:
Code:
Sub BulkFileRename() ' 05/13/2022
' This macro loops through all Word (.docx) and .rtf files in a user-selected
' folder. If a file contains a specified string, then the file is renamed, by
' removing the string. (Technically, a copy of the file is made with the new
' name, and the original is deleted.) If a file with that name already exists,
' then the old file is overwritten with the renamed file.
Dim strToRemove As String, strPath As String, strNewName As String
Dim objFile As File, objFolder As Folder
Dim objFSO As Scripting.FileSystemObject
' String (case-sensitive) to remove from file names:
strToRemove = "_Audited"
' Get the folder via function:
strPath = fcnFolderPicker
' If the user didn't choose a folder, then exit sub:
If strPath = "" Then
Exit Sub
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
' Loop through all files in the folder:
For Each objFile In objFSO.GetFolder(strPath).Files
' If the file has the string to be removed:
If InStr(objFile.Name, strToRemove) <> 0 Then
' ...and the file is either a .docx or .rtf:
If InStr(objFile.Name, ".docx") <> 0 Or InStr(objFile.Name, ".rtf") <> 0 Then
' ...then create a new file name by replacing the string to remove with nothing:
strNewName = Replace(objFile.Name, strToRemove, "")
End If
' Copy file with the string removed from the name; overwrite existing version, if necessary:
objFSO.CopyFile objFolder.path & "\" & objFile.Name, objFolder.path & "\" & strNewName, True
' Delete the original file:
objFSO.DeleteFile (objFile.path)
End If
Next objFile
End Sub
Function fcnFolderPicker() As String ' 05/13/2022
Dim FolderPicker As FileDialog
Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FolderPicker
.Title = "Choose the folder containing your files"
.AllowMultiSelect = False
' If the user cancels, then exit function:
If .Show <> -1 Then
Exit Function
Else
fcnFolderPicker = .SelectedItems(1) & "\"
End If
End With
End Function