Rename All Files in Folder with Added Variable Value without Opening - vba

Question

I have a large number of *.xlsx files in subfolders based on month of the year (e.g., 01, 02, 03) by district. I'd like to loop through each file and append the period associated with the subfolder to the end of each file name. For example, Atlanta 01 Bob Jones.xlsx would become Atlanta 01 Bob Jones 01.xlsx. I have looked at examples on this forum and elsewhere and can't find something similar enough to do what I want. Any help would be greatly appreciated!
This is what I have so far:
Sub DSMReports1()
Dim MM As String
MM = InputBox("Enter Month for reporting in MM format: 01-12", , Range("C6").Value)
Range("C6").Value = MM
Application.DisplayAlerts = False
Dim DistrictDSM As String
Dim Path As String
Dim DistPeriodFileOld As String
Dim DistPeriodFileNew As String
Dim Total As Integer
Dim Period As Integer
DistrictDSM = Range("B3").Value 'Selected from a dropdown list
Path = "H:\Accounting\Monthend 2018\DSM Files\" & DistrictDSM & "\P" & MM & "\"
DistPeriodFileOld = Dir(Path & "*.xlsx")
DistPeriodFileNew = Dir(Path & "*.xlsx") 'This is where I'd like to append the period value found in MM
Do While DistPeriodFileOld <> ""
Name DistPeriodFileOld As DistPeriodFileNew
DistPeriodFileOld = Dir
Loop
Next DistrictDSM
End Sub

Answer 1

If you have a large number of *.xlsx, I believe that this code can help you.
Sub ReadAllFiles(ByVal s As String)
'Remember: Add Reference Microsoft Scripting Runtime
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = ".XLS" Or UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = "XLSX" Then
Debug.Print "readind file " & myFile.Path
End If
Next
End Sub
After, you need to replace old name to new name.
Function RenameFiles(p_file As String) As String
'Atlanta 01 Bob Jones.xlsx
Dim v_name As String
Dim v_extension As String
If UCase(Mid$(p_file, Len(p_file) - 3, 4)) = ".XLS" Then
v_name = Mid$(p_file, 1, Len(p_file) - 4) 'Atlanta 01 Bob Jones
v_extension = Mid$(p_file, Len(p_file) - 2, 4) '.xls
End If
If UCase(Mid$(p_file, Len(p_file) - 3, 4)) = "XLSX" Then
v_name = Mid$(p_file, 1, Len(p_file) - 5) 'Atlanta 01 Bob Jones
v_extension = Mid$(p_file, Len(p_file) - 3, 4) '.xls
End If
RenameFiles = v_name & " 01" & "." & v_extension 'warning --> I fixed 01 here
End Function
Finally:
Sub ReadAllFiles(ByVal s As String)
'Remember: Add Reference Microsoft Scripting Runtime
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = ".XLS" Or UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = "XLSX" Then
Debug.Print "reading file " & myFile.Path
FileCopy myFile.Path, RenameFiles(myFile.Path) 'Here we COPY original file to new file
End If
Next
End Sub
I hope I have helped you.