Deleting part of string in subfolder name then in files within - excel

Question

I have a ton of files that have a common string in the name "mch". Within one folder there are hundreds of subfolders named with this common string, then within those there are 5 pictures named similar; example picfront1234mch. I need to get rid of the mch at the end of all the names of picture files and the folders they are in. I was attempting a couple different examples from the web but non to work. I wrote this code to find the file names in the subfolders and to delete the last 3 characters of the name but its deleting the extensions instead. I have used the move/copy/ rename method in the past but I lost some of my old code and can’t figure out how use it again. Any suggestions on how to do this better?
Code ive been trying
Option Explicit
Sub ListFiles()
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
'Assign the top folder to a variable
strTopFolderName = "C:\Users\aholiday\Desktop\Test"
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim str As String
Debug.Print Now
Application.SendKeys "^g ^a {DEL}"
Application.ScreenUpdating = False
'Loop through each folder in the Topfolder
For Each objFile In objFolder.Files
str = objFile.Name
Debug.Print str
'delete last 3 chara of string
str = Left(str, Len(str) - 3)
Debug.Print str
Next objFile
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
Application.ScreenUpdating = True
End Sub

Answer 1

Usage:
RemoveTextFromFileName "mch", "I:\stackoverflow\temp"
Sub RemoveTextFromFileName(txt As String, FolderName As String)
Dim file
If Not Right(FolderName, 1) = "\" Then FolderName = FolderName & "\"
file = Dir(FolderName)
While (file "")
If InStr(file, txt) > 0 Then
FileCopy FolderName & file, FolderName & Replace(file, txt, "")
Kill FolderName & file
End If
file = Dir
Wend
End Sub
Update: Remove string from folder, sub folders, and file names.
These functions will recursively search the root folder and all it's subfolders to rename files and folders.
Usage:
Public Sub ProcessFoldersAndFiles()
ReplaceStringFileNames "C:\Data Files\mch files\", "mch"
ReplaceStringDirectories"C:\Data Files\mch files\", "mch"
End Sub
Here are the functions:
Sub ReplaceStringDirectories(FolderPath As String, SearchString As String, Optional ReplacementString As String = "", Optional fso As Object)
Dim fld, thisFolder
Dim NewName As String, PathOnly As String
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
Set thisFolder = fso.getFolder(FolderPath)
For Each fld In thisFolder.Subfolders
ReplaceStringDirectories fld.Path, SearchString, ReplacementString
Next
If InStr(thisFolder.Name, SearchString) Then
NewName = Replace(thisFolder.Name, SearchString, ReplacementString, , , vbTextCompare)
PathOnly = Left(thisFolder.Path, InStrRev(thisFolder.Path, "\"))
Do Until Not fso.FolderExists(PathOnly & NewName)
NewName = "_" & NewName
Loop
thisFolder.Name = NewName
End If
End Sub
Sub ReplaceStringFileNames(FolderPath As String, SearchString As String, Optional ReplacementString As String = "", Optional fso As Object)
Dim f, fld, thisFolder
Dim NewName As String, PathOnly As String
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
Set thisFolder = fso.getFolder(FolderPath)
For Each fld In thisFolder.Subfolders
ReplaceStringFileNames fld.Path, SearchString, ReplacementString
Next
For Each f In thisFolder.Files
If InStr(f.Name, SearchString) Then
NewName = Replace(f.Name, SearchString, ReplacementString, , , vbTextCompare)
PathOnly = Left(f.Path, InStrRev(thisFolder.Path, "\"))
Do Until Not fso.FolderExists(PathOnly & NewName)
NewName = "_" & NewName
Loop
f.Name = NewName
End If
Next
End Sub