1
\$\begingroup\$

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

enter image description here

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

enter image description here

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

enter image description here

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
\$\endgroup\$

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.