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]

Hi, a VBA demonstration for starters :​

Sub Demo1()
      Const P = "D:\Tests4Noobs\"
        Dim V, W, F$, X, N$
    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
    With CreateObject("Scripting.FileSystemObject")
          F = Dir$(P)
    While F > ""
          X = Application.Match(1, Application.Match(V, Array(F), 0), 0)
          If IsNumeric(X) Then N = P & W(X, 1) & Mid(F, InStrRev(F, ".")): If Not .FileExists(N) Then Name P & F As N
          F = Dir$
    Wend
    End With
End Sub

 

[Marc L]

​

Little glitch : the previous code renames the file in the source folder so I will revamp it in my next post …​

 

[Marc L]

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

 

[cmowla]

Here's code to do the entire thing: ( Insert and run VBA macros in Excel - step-by-step guide - Ablebits.com )

(This assumes that the output folder is Empty. Otherwise we have to write code to delete all of the files in it first.)

New Microsoft Excel Worksheet.xlsb
	A	B	C
1	Code	Result	09Sep21
2	0001	Singapore
3	002T	Spain
4	0003	France
5	0005	Australia
Sheet1

Option Explicit

Sub Rename()

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 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 = 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) & "_" & 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

 

[Marc L]

​

As post #4 code does the 'entire thing' whatever if the destination folder is empty or not …​

 

[cmowla]

​

As post #4 code does the 'entire thing' whatever if the destination folder is empty or not …​

I couldn't get your code to run.

The sheet in my Workbook is named Sheet1. This is the code I ran (to match the names of the input and output folders my code uses):

Sub Demo1r()
      Const P = "C:\Users\Chris\Desktop\Test Input folder\"
        Dim V, W, F$, X
    With Range("Sheet1!A2:A" & [Sheet1!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:\Users\Chris\Desktop\Test Output folder\" & W(X, 1) & Mid(F, InStrRev(F, "."))
          F = Dir$
    Wend
End Sub

@unknownymous , if you want the program to automatically delete all files in the output folder first, just add the following line of code at the beginning (the Kill line):

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.

Kill outputFolder & "\*.*"

.
.
.

 

[cmowla]

@unknownymous , if you want the program to automatically delete all files in the output folder first, just add the following line of code at the beginning (the Kill line):

Nope, not there. Here. (Sorry!)

'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 & "\*.*"

 

[Marc L]

The sheet in my Workbook is named Sheet1

Yes but as the OP wrote « a Directory tab » the reason why I used this tab name …​

​

 

[cmowla]

Yes but as the OP wrote « a Directory tab » the reason why I used this tab name …​

​

I wasn't complaining about the sheet name. I was explaining (hoping that you would show me) how I used (misused) your code that it will not run. What did I do wrong? (And obviously mine works on the active sheet.)