Rename file Based on Cell value and Criteria

[unknownymous]

Hi Gurus,

Hope all is well.

Is it possible to rename a file based on it's equivalent cell value and criteria?

Scenario: I have different multiple files in a folder and in different file format

Sample filenames in a folder

0001 Datasheetxx.pdf
Dataaaaaasheetxx_002T.xlsx
Dataaa_0003_aaasheetxx.txt
0005 Dataaa__aaasheetxx.xls

What the macro does is to extract the 4 digit code in the file. It can be found in front, middle or end of the file name. In the macro file, there's a Directory tab that can check the equivalent name and add the date on Cell A3.

Code	Result	09Sep21
0001	Singapore
002T	Spain
0003	France
0005	Australia

Final renamed version will look like this and save to a different folder.

Singapore_09Sep21.pdf
Spain_09Sep21.xlsx
France_09Sep21.txt
Australia_09Sep21.xls


Any thoughts will be much appreciated.


Thank you!

 

[Marc L]

Hoping the active sheet is the Directory tab on the OP side …​

 

[cmowla]

​

Hoping the active sheet is the Directory tab on the OP side …​

Well okay then: (This code encompasses both the non-empty output folder issue and the sheet name issue.)

Option Explicit

Sub Rename()

Dim sheetName As String
sheetName = "Directory" '(Make "ActiveSheet.name" if it's the active sheet.)

Dim inputFolder As String
inputFolder = "C:\Users\Chris\Desktop\Test Input folder" 'Folder where original file names are.

Dim outputFolder As String
outputFolder = "C:\Users\Chris\Desktop\Test Output folder" 'Folder where renamed files will be.

'Create a copy of all the files of the inputFolder and put them in the outputFolder.
'If the outputFolder doesn't exist, create it first.
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

If Len(Dir$(outputFolder & "\*.*")) > 0 Then Kill outputFolder & "\*.*"
If fso.FolderExists(inputFolder) = True Then fso.CopyFolder Source:=inputFolder, Destination:=outputFolder

'Now put the Data in the table in the Active Sheet into a multidimensional array.
Dim lastrow As Long
lastrow = Sheets(sheetName).Range("A" & Rows.Count).End(xlUp).Row

ReDim codes_Countries_FilePaths(0 To lastrow, 0 To lastrow, 0 To lastrow) As String
Dim i As Long
i = 2
Do While i <= lastrow
    codes_Countries_FilePaths(i - 1, 0, 0) = Cells(i, 1).Value
    codes_Countries_FilePaths(0, i - 1, 0) = Cells(i, 2).Value
    i = i + 1
Loop

'Loop through the files in the inputFolder and map them to the values in the table.
Dim fldr As Object: Set fldr = fso.GetFolder(outputFolder)
Dim fil As Object
i = 1
Do While i <= lastrow - 1
    For Each fil In fldr.Files
        If InStr(fil.Path, codes_Countries_FilePaths(i, 0, 0)) > 0 Then
            codes_Countries_FilePaths(0, 0, i) = fil.Path
            Exit For
        End If
    Next fil
    i = i + 1
Loop

'The map.
'i = 1
'Do While i <= lastrow - 1
'    Debug.Print codes_Countries_FilePaths(i, 0, 0), codes_Countries_FilePaths(0, i, 0), codes_Countries_FilePaths(0, 0, i)
'    i = i + 1
'Loop

On Error Resume Next
'Rename the files.
Dim currentFileExtension As String
i = 1
Do While i <= lastrow - 1
    currentFileExtension = SubString(codes_Countries_FilePaths(0, 0, i), InStrRev(codes_Countries_FilePaths(0, 0, i), "."), Len(codes_Countries_FilePaths(0, 0, i)))
    fso.GetFile(codes_Countries_FilePaths(0, 0, i)).Name = codes_Countries_FilePaths(0, i, 0) & "_" & Sheets(sheetName).Range("C1").Value & currentFileExtension
    i = i + 1
Loop

Set fso = Nothing

End Sub


Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(inputString As String, Start As Integer, Finish As Integer)
On Error GoTo Quit
SubString = Mid(inputString, Start, Finish - Start + 1)
Quit:
End Function

 

[unknownymous]

The revamped demonstration :​

Sub Demo1r()
      Const P = "C:\SourceFolder\"
        Dim V, W, F$, X
    With Range("Directory!A2:A" & [Directory!A1].CurrentRegion.Rows.Count).Columns
        V = .Item(1).Value2
        W = .Parent.Evaluate(.Item(2).Address & "&""_" & .Cells(0, 3).Text & """")
    End With
          F = Dir$(P)
    While F > ""
          X = Application.Match(1, Application.Match(V, Array(F), 0), 0)
          If IsNumeric(X) Then FileCopy P & F, "C:\Destination\" & W(X, 1) & Mid(F, InStrRev(F, "."))
          F = Dir$
    Wend
End Sub

Thank you!

 

[unknownymous]

Well okay then: (This code encompasses both the non-empty output folder issue and the sheet name issue.)

Option Explicit

Sub Rename()

Dim sheetName As String
sheetName = "Directory" '(Make "ActiveSheet.name" if it's the active sheet.)

Dim inputFolder As String
inputFolder = "C:\Users\Chris\Desktop\Test Input folder" 'Folder where original file names are.

Dim outputFolder As String
outputFolder = "C:\Users\Chris\Desktop\Test Output folder" 'Folder where renamed files will be.

'Create a copy of all the files of the inputFolder and put them in the outputFolder.
'If the outputFolder doesn't exist, create it first.
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

If Len(Dir$(outputFolder & "\*.*")) > 0 Then Kill outputFolder & "\*.*"
If fso.FolderExists(inputFolder) = True Then fso.CopyFolder Source:=inputFolder, Destination:=outputFolder

'Now put the Data in the table in the Active Sheet into a multidimensional array.
Dim lastrow As Long
lastrow = Sheets(sheetName).Range("A" & Rows.Count).End(xlUp).Row

ReDim codes_Countries_FilePaths(0 To lastrow, 0 To lastrow, 0 To lastrow) As String
Dim i As Long
i = 2
Do While i <= lastrow
    codes_Countries_FilePaths(i - 1, 0, 0) = Cells(i, 1).Value
    codes_Countries_FilePaths(0, i - 1, 0) = Cells(i, 2).Value
    i = i + 1
Loop

'Loop through the files in the inputFolder and map them to the values in the table.
Dim fldr As Object: Set fldr = fso.GetFolder(outputFolder)
Dim fil As Object
i = 1
Do While i <= lastrow - 1
    For Each fil In fldr.Files
        If InStr(fil.Path, codes_Countries_FilePaths(i, 0, 0)) > 0 Then
            codes_Countries_FilePaths(0, 0, i) = fil.Path
            Exit For
        End If
    Next fil
    i = i + 1
Loop

'The map.
'i = 1
'Do While i <= lastrow - 1
'    Debug.Print codes_Countries_FilePaths(i, 0, 0), codes_Countries_FilePaths(0, i, 0), codes_Countries_FilePaths(0, 0, i)
'    i = i + 1
'Loop

On Error Resume Next
'Rename the files.
Dim currentFileExtension As String
i = 1
Do While i <= lastrow - 1
    currentFileExtension = SubString(codes_Countries_FilePaths(0, 0, i), InStrRev(codes_Countries_FilePaths(0, 0, i), "."), Len(codes_Countries_FilePaths(0, 0, i)))
    fso.GetFile(codes_Countries_FilePaths(0, 0, i)).Name = codes_Countries_FilePaths(0, i, 0) & "_" & Sheets(sheetName).Range("C1").Value & currentFileExtension
    i = i + 1
Loop

Set fso = Nothing

End Sub


Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(inputString As String, Start As Integer, Finish As Integer)
On Error GoTo Quit
SubString = Mid(inputString, Start, Finish - Start + 1)
Quit:
End Function

Thanks for sharing your insights