How to rename multiple files in single folder with the option to select the parent folder?-CodePudding

I want to write a program that will rename all the files in a user-selected folder wherein all files are named roughly according to the formula "WEEKLY 00.00.00" where "00.00.00" is <month.day.year> so that the result is "00_00_00", where the two corresponding dates are equal and the redundant prefix is eliminated.

I found the following code, which looks like it could be modified to do this:

Sub RenameFiles()

Dim xDir As String
Dim xFile As String
Dim xRow As Long

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
If .Show = -1 Then
    xDir = .SelectedItems(1)
    xFile = Dir(xDir & Application.PathSeparator & "*")
    Do Until xFile = ""
        xRow = 0
        On Error Resume Next
        xRow = Application.Match(xFile, Range("A:A"), 0)
        If xRow > 0 Th
            Name xDir & Application.PathSeparator & xFile As _
            xDir & Application.PathSeparator & Cells(xRow, "B").Value
        End If
        xFile = Dir
    Loop
End If
End With
End Sub

However, I do not know how to modify it to suit my specific needs because vba is so foreign to me. For now, it does allow the user to determine the directory (no further event takes place for me, but it throws no error; yes, the folder is populated), and it appears like it's meant to place the old file names in column A of an excel file and the new names of the corresponding file and row value in column B of the same excel file. Is that the case?

Might anyone provide some constructive feedback on this matter? Thanks.

CodePudding user response：

Not sure what you meant by "all files are named roughly" so for flexibility consider using a Regular Expression.

Option Explicit

Sub RenameFiles()

    Dim xDir As String, xFile As String
    Dim n As Long, sNew As String
    
    Dim regex, m
    Set regex = CreateObject("vbscript.regexp")
    With regex
        .Global = True
        .MultiLine = False
        .IgnoreCase = True
        ' capture groups () $1 $2 $3 $4 $5
        .Pattern = "(.*)(?:WEEKLY (\d\d)\.(\d\d)\.(\d\d))(.*)"
    End With

    ' select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            xDir = .SelectedItems(1)
        End If
    End With
    If xDir = "" Then Exit Sub
            
    ' scan files
    xDir = xDir & Application.PathSeparator
    xFile = Dir(xDir & "*")
    Do Until xFile = ""
        ' select pattern matching files
        If regex.test(xFile) Then
            ' modify name
            sNew = regex.Replace(xFile, "$1$2_$3_$4$5")
            Name xDir & xFile As xDir & sNew
            
            Debug.Print xFile, sNew
            n = n   1
        End If
        xFile = Dir ' next file
        
    Loop
    MsgBox n & " files renamed", vbInformation, xDir
        
End Sub

CodePudding user response：

If you're looking to return some file names, change them, build folders... or whatever else you want to do in the file system, Using a FileSystemObject can be really helpful for new users.
This code below will just change your file name from "00.00.00" to "00_00_00":

Option Explicit
Sub RenameFiles()
    
    Dim xDir As String      'Directory
    Dim oFSO As Object      'File System Object
    Dim oFolder As Object   'FSO Folder
    Dim oFile As Object     'FSO File
    Dim ExtType As String   'Extension Type
    Dim NewDir As String    'New File Directory
    Dim NewName As String   'New File Name
    
    ' Do not include period -> Good:="xlsx" ; Bad:=".xlsx"
    ExtType = "xlsx"
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        xDir = .SelectedItems(1)
    End With
    
    Set oFolder = oFSO.getfolder(xDir)
    
    ' > This is how to print the names on each of the files in the folder.
    For Each oFile In oFolder.Files
        Debug.Print oFile.Name
    Next oFile
    
    ' > This is an example of how to rename files.
    '   You can make as many changes to the file name as you want befor
    '   sticking it all back together and renaming.
    '   This example only replaces "." with "_"
    For Each oFile In oFolder.Files
        ' > Check if file is a specified file type.
        If oFSO.getextensionname(oFile.Path) = ExtType Then
            ' > Build New Directory:
            NewName = Left(oFile.Name, Len(oFile.Name) - Len(ExtType) - 1)
            NewName = Replace(NewName, ".", "_")
            NewDir = xDir & "\" & NewName & "." & ExtType
            Debug.Print NewDir
            ' > Rename File
            '   |_Rename_|_old_path_|_new_path_|
            oFSO.movefile oFile.Path, NewDir
        End If
    Next oFile
    

End Sub

**EDIT**

If you want to remove everything but the date:

Option Explicit
Sub RenameFiles()
    
    Dim xDir As String      'Directory
    Dim oFSO As Object      'File System Object
    Dim oFolder As Object   'FSO Folder
    Dim oFile As Object     'FSO File
    Dim ExtType As String   'Extension Type
    Dim NewDir As String    'New File Directory
    Dim NewName As String   'New File Name
    
    ' Do not include period -> Good:="xlsx" ; Bad:=".xlsx"
    ExtType = "xlsx"
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        xDir = .SelectedItems(1)
    End With
    
    Set oFolder = oFSO.getfolder(xDir)
    
    ' > This is an example of how to rename files.
    '   You can make as many changes to the file name as you want befor
    '   sticking it all back together and renaming.
    '   This example only replaces "." with "_"
    For Each oFile In oFolder.Files
        ' > Check if file is a specified file type.
        If oFSO.getextensionname(oFile.Path) = ExtType Then
            ' > Build New Directory:
            NewName = Left(oFile.Name, Len(oFile.Name) - Len(ExtType) - 1)
            NewName = CleanStringOnlyDate(NewName)
            NewName = Replace(NewName, ".", "_")
            NewDir = xDir & "\" & NewName & "." & ExtType
            Debug.Print NewDir
            ' > Rename File
            '   |_Rename_|_old_path_|_new_path_|
            oFSO.movefile oFile.Path, NewDir
        End If
    Next oFile
    
End Sub
Function CleanStringOnlyDate(Str As String) As String
    Dim I As Long
    For I = 1 To Len(Str) - 7
        If Mid(Str, I, 8) Like "##*##*##" Then
            CleanStringOnlyDate = Mid(Str, I, 8)
            Exit Function
        End If
    Next I
End Function

From:

TO:

To add words:

...
            NewName = CleanStringOnlyDate(NewName)
            NewName = "ExampleFile" & Replace(NewName, ".", "_")
            NewDir = xDir & "\" & NewName & "." & ExtType
...