Rename file Based on Cell value and Criteria

unknownymous

Board Regular
Joined
Sep 19, 2017
Messages
249
Office Version
  1. 2016
Platform
  1. Windows
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.

CodeResult09Sep21
0001Singapore
002TSpain
0003France
0005Australia

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!
 

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

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
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.)
VBA Code:
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
 
Last edited:
Upvote 0
The revamped demonstration :​
VBA Code:
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!
 
Upvote 0
Well okay then: (This code encompasses both the non-empty output folder issue and the sheet name issue.)
VBA Code:
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 :)
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top