Get & change file names from folder

Question

This was originally posted as a Stack Overflow answer.

Objective

Import all filenames from a folder & change the filename using a mapping table.

Challenge

As described in the original posting, using InStr can give unexpected results when a file name is also a substring of another file name. In order to navigate this, I created a mapping table to handle duplicate file names, which have parentheses as a differentiator.

• Folder setup

• Table (Used to determine the target file name change)

• Mapping Table (Constructed using the "Get_Filenames" sub)

Code

Option Explicit

Sub Parent_Macro_Change_Filename()

'Split out the subs to make it easier for me to break down, no technical requirement

Call Get_FileNames
Call Format_Filename
Call Change_FileName

MsgBox "Completed"

End Sub

Sub Get_FileNames()

Const strFolder = "C:\Users\jason\"

Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("Get_Filenames")

'Set folder to loop & transpose file names

Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFolder As Object: Set objFolder = objFSO.GetFolder(strFolder)

Dim LastRow As Long
Dim file As Variant
Dim x As Long

'Loop folder & reset LastRow variable for each iteration

    With ws
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            For Each file In objFolder.Files
            
             .Cells(LastRow, 1).Value = file.Name
             
             LastRow = LastRow + 1
             
            Next file
    End With

End Sub

Sub Format_Filename()

Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("Get_Filenames")

Dim LastRow, x As Long

'Remove the file name extension. Note this would be problematic_
'if there are more than one full stop.

    With ws
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        For x = 1 To LastRow
        
            .Cells(x, 2).Value = Left(.Cells(x, 1).Value, InStr(.Cells(x, 1).Value, ".") - 1)
        Next
      
'If there is a space in the file name, trim it by_
'extracting name before space.

            For x = 1 To LastRow
            
                If InStr(.Cells(x, 2).Value, " ") Then
                    
                    .Cells(x, 3).Value = Left(.Cells(x, 2).Value, InStr(.Cells(x, 2).Value, " ") - 1)
                Else
                
                    .Cells(x, 3).Value = .Cells(x, 2).Value
                End If
                
            Next
        
'Get the target file name using a lookup
        
    Dim wsTable As Worksheet: Set wsTable = ActiveWorkbook.Sheets("Table")
    
        For x = 1 To LastRow
        
            .Cells(x, 4).Value = WorksheetFunction.VLOOKUP(.Cells(x, 3).Value, wsTable.Range("A:B"), 2, 0)
        Next
    
'Construct the target file name including the file extension_
'This way I can create an "if equals then change..."
    
        For x = 1 To LastRow
        
        .Cells(x, 5).Value = Replace(.Cells(x, 1), .Cells(x, 3), .Cells(x, 4))
        
        Next x
    
    End With
End Sub

Sub Change_FileName()

Const strFolder = "C:\Users\jason\"

Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("Get_Filenames")

Dim file As Variant
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFolder As Object: Set objFolder = objFSO.GetFolder(strFolder)
Dim filename As String

Dim LastRow, x As Long

    With ws
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

'Load the entire file name to my variable

        For Each file In objFolder.Files
                filename = file.Name
                    
'If the file name is found on the mapping table, change the value_
'to the result constructed in the previous sub.
                
                    For x = 1 To LastRow
                        If filename = .Cells(x, 1).Value Then
                            
                            file.Name = .Cells(x, 5).Value
                        Else
'Just using Debug.Print to hopefully build a log file alerting the user_
'If there was no change to the file name.

                            Debug.Print filename
                        End If
                    Next x
                
        Next file
    End With
End Sub