VBA - Loop Folder - Replace substring in filename-CodePudding

Challenge:

Looping through a folder to update a filename. however, there are duplicate filenames, differentiated with parenthesis.

When I execute the attached code, it updates the entire filename without preserving the parenthesis element, causing a compile error.

Objective

Using the mapping on tab 'Table', loop through the folder & update the filename with the new code; Offset(0,1).

Example:

Old - 874031 (1).jpg New - 100 (1).jpg

I have searched the site but I'm unable to achieve the desired result, any help is greatly appreciated.

Sub Find_Replace_FileName()

Dim strFolder As String
    
strFolder = "C:\Users\jason\"
    
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Table")

Dim x As Long, LastRow As Long
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

    With ws
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
        
        For Each file In objFolder.Files
        filename = Left(file.Name, InStr(file.Name, ".") - 1)
            For x = 2 To LastRow

                'Using this method I want to substitue the_
                'filename found with corresponding value
                
                If InStr(filename, .Cells(x, 1).Value) Then
                    
                    file.Name = Replace(filename, filename, .Cells(x, 1).Offset(0, 1).Value) & ".jpg"
                End If
    
            Next x
        Next file
    End With

End Sub

CodePudding user response：

Option Explicit
Sub Find_Replace_FileName1()
        
    Const strFolder = "C:\Users\jason\"
          
    Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder As Object: Set objFolder = objFSO.GetFolder(strFolder)
    
    Dim ws As Worksheet, ar, file As Object
    Dim LastRow As Long, i As Long, n As Long, s As String
    
    Set ws = ActiveWorkbook.Sheets("Table")
    With ws
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        ar = .Range("A2:B" & LastRow)
        For Each file In objFolder.Files
            s = file.Name
            For i = 1 To UBound(ar)
                If InStr(s, ar(i, 1)) Then
                   file.Name = Replace(s, ar(i, 1), ar(i, 2))
                   n = n   1
                   'Debug.Print n, s, file.Name
                   Exit For
                End If
            Next
        Next
    End With
    MsgBox n & " files renamed", vbInformation

End Sub

CodePudding user response：

Rename Files in a Folder Using a List in a Worksheet

Edited (Corrected) Code

This will rename the files whose base names (the names without extension) start with one of the strings in the first column. It will replace this starting substring with the string found in the same row of the second column.

Option Explicit


Sub RenameFilesWithaTwist()
    
    Dim dFolderPath As String: dFolderPath = "C:\Users\jason\"
    ' You could make it more generic (flexible, private) with
    'dFolderPath = Environ("USERPROFILE") & "\"

    ' Reference the range.

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets("Table")
    Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If LastRow < 2 Then Exit Sub ' no data
    
    Dim rg As Range: Set rg = ws.Range(ws.Cells(2, "A"), ws.Cells(LastRow, "B"))
    
    ' Write the values from the range to an array.
    Dim Data As Variant: Data = rg.Value

    ' Write the unique values, excluding blanks and error vales,
    ' from the array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim oKey As Variant
    Dim nKey As Variant
    Dim r As Long
    
    For r = 1 To UBound(Data, 1)
        oKey = Data(r, 1)
        If Not IsError(oKey) Then
            If Len(oKey) > 0 Then
                nKey = Data(r, 2)
                If Not IsError(nKey) Then
                    If Len(nKey) > 0 Then
                        dict(CStr(oKey)) = CStr(nKey)
                    End If
                End If
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    
    ' Using the FileSystemObject object, loop through the files in the folder,
    ' and in the dictionary, find their base names in the KEYS
    ' and use the associated ITEMS to rename the files.
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(dFolderPath)
    
    Dim fsoFile As Object
    Dim doBaseName As String
    Dim doFileName As String
    Dim dnFileName As String
    Dim fCount As Long
    
    For Each fsoFile In fsoFolder.Files
        doFileName = fsoFile.Name
        doBaseName = fso.GetBaseName(doFileName)
        For Each oKey In dict.Keys
            If InStr(1, doBaseName, oKey, vbTextCompare) = 1 Then ' begins with
                dnFileName = dict(oKey)
                If Len(doBaseName) > Len(oKey) Then
                    dnFileName = dnFileName & Right(doBaseName, _
                        Len(doBaseName) - Len(oKey))
                End If
                dnFileName = dnFileName & "." & fso.GetExtensionName(doFileName)
                fsoFile.Name = dnFileName
                fCount = fCount   1
                Exit For
            End If
        Next oKey
    Next fsoFile

    ' Inform.
    MsgBox "Files renamed: " & fCount, vbInformation

End Sub

Initial Code

This will rename the files whose base name (the name without extension) is found in the first column, by replacing it with the name in the same row of the second column.

Sub RenameFiles()
    
    Dim dFolderPath As String: dFolderPath = "C:\Users\jason\"
    ' You could make it more generic (flexible, private) with
    'dFolderPath = Environ("USERPROFILE") & "\"

    ' Reference the range.

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets("Table")
    Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If LastRow < 2 Then Exit Sub ' no data
    
    Dim rg As Range: Set rg = ws.Range(ws.Cells(2, "A"), ws.Cells(LastRow, "B"))
    
    ' Write the values from the range to an array.
    Dim Data As Variant: Data = rg.Value

    ' Write the unique values, excluding blanks and error vales,
    ' from the array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim oKey As Variant
    Dim nKey As Variant
    Dim r As Long
    
    For r = 1 To UBound(Data, 1)
        oKey = Data(r, 1)
        If Not IsError(oKey) Then
            If Len(oKey) > 0 Then
                nKey = Data(r, 2)
                If Not IsError(nKey) Then
                    If Len(nKey) > 0 Then
                        dict(CStr(oKey)) = CStr(nKey)
                    End If
                End If
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    
    ' Using the FileSystemObject object, loop through the files in the folder,
    ' and in the dictionary, find their base names in the KEYS
    ' and use the associated ITEMS to rename the files.
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(dFolderPath)
    
    Dim fsoFile As Object
    Dim doBaseName As String
    Dim doFileName As String
    Dim fCount As Long
    
    For Each fsoFile In fsoFolder.Files
        doFileName = fsoFile.Name
        doBaseName = fso.GetBaseName(doFileName)
        If dict.Exists(doBaseName) Then
            fsoFile.Name = dict(doBaseName) _
                & "." & fso.GetExtensionName(doFileName)
            fCount = fCount   1
        End If
    Next fsoFile

    ' Inform.
    MsgBox "Files renamed: " & fCount, vbInformation

End Sub