• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Replace part of the xls files' name in sub folder by part of cell value in each file.

I have a folder with multiple subfolders. Each subfolder contains a number of files (Xls). The files are downloaded from the company portal. The file names are comprised by the report code (first 10 characters) and followed with date and time. (BCAR022_A_20161206_162511350) Each workbook has just 1 worksheet.

What I need is a macro which first asks me for the target folder, then open each workbook, extract 8 characters from the right (excluding "/") from cell A6, put these character on the right while preserving the first 10 characters of the original file name. Close the file, repeat until the last file. Example: BCAR022_A_20161206_162511350.xls >>> BCAR022_A_20150101.xls

Right now I do all the above manually. The downloading of the workbooks itself is time-consuming and the renaming process takes up a lot of time.

Any help will be appreciated.
 
Can you upload sample workbook? I'll need to see what's actually in cell A6. Code will depend on it.
 
See if this works.
Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir, Right$([a6], 8)
End Sub

Sub ReNameFiles(ByVal myDir As String, newName As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                "." & sfo.GetExtensionName(myFile.Name)
        Name myDir & "\" & myFile.Name As myDir & "\" & temp
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path, newName
    Next
End Sub
 
Hi Chihiro, sorry for the late reply, attached is one of the many files. Thank you for your input!
 

Attachments

  • NCIR024_A_20150204_154621790.xls
    23.5 KB · Views: 4
Last edited:
Hi, I tried the code, it retained the first part of the file name, but it doesn't put the last 8 characters from cell A6 to the file name. The excel into the "file already exists error." Thanks!

Is it possible to only scan and replace the .xls that contain "_A_" in the filename?

See if this works.
Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir, Right$([a6], 8)
End Sub

Sub ReNameFiles(ByVal myDir As String, newName As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                "." & sfo.GetExtensionName(myFile.Name)
        Name myDir & "\" & myFile.Name As myDir & "\" & temp
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path, newName
    Next
End Sub
 
Here, just modified jindon's code a bit due to your content in A6.
And added check for "_A_".

Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir, Right$(Replace([a6], "/", ""), 8)
End Sub

Sub ReNameFiles(ByVal myDir As String, newName As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        If InStr(1, myFile.Name, "_A_") > l Then
            temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                    "." & sfo.GetExtensionName(myFile.Name)
            Name myDir & "\" & myFile.Name As myDir & "\" & temp
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path, newName
    Next
End Sub

Also, make sure that the file with the code is in different folder than target folder for changing names.
 
Change
Code:
    ReNameFiles myDir, Right$([a6], 8)
to
Code:
    ReNameFiles myDir, Right$(Replace([a5],"/",""), 8)
 
Thanks for the quick reply from Chihiro and jindon! I just tried the code and here is a screen shot from a sub folders. It seems that the macro didn't paste the last 8 characters to the filename.
 

Attachments

  • Rename.JPG
    Rename.JPG
    35.4 KB · Views: 7
Worked fine on my end when I tested.

For the code I posted to work...
"Transaction Date :2015/02/02 to 2015/02/02", should be in cell A6.
If it's in A5, use jindon's modification.
 
I am sorry for making it so confusing, the cell should be A5. I corrected the code and tried for a couple times, but something unexpected come up. Please see the picture for a better idea, thanks! The left part is fine but the 8 characters are extracted some unknown place.
 

Attachments

  • Result.JPG
    Result.JPG
    30.4 KB · Views: 20
Can not replicate your problem here.

No idea unless A5 contains different data from the file uploaded.
 
Hi, some update here. I restarted excel, the result becomes very consistent like the attached picture. It could not place the last 8 characters from A5 to the corresponding files.
 

Attachments

  • SameIssue.JPG
    SameIssue.JPG
    28.2 KB · Views: 10
One possibility is you are not running the code from Sheet1...
Try this anyway.
Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir, Right$(Replace([sheet1!a5], "/", ""), 8)
End Sub

Sub ReNameFiles(ByVal myDir As String, newName As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        If myFile.Name Like "*_A_*" Then
            temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                    "." & sfo.GetExtensionName(myFile.Name)
            Name myDir & "\" & myFile.Name As myDir & "\" & temp
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path, newName
    Next
End Sub
 
Oh, I see why I am not getting the result! I feel so embarrassed! My goal was trying to replace the later part of the filename of the file after getting the cell value from the very same file.

Let's say the cell value of A5 from the file NCIR022_A_20160707_122021130.xls is "11/11/2011", I would like the filename to become NCIR022_A_11112011.xls. The A5 value in the next file may be different and the later part of filename should replace accordingly.

I hope it makes sense now, thank you so much!
 
OK

Let's see if this works
Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir
End Sub

Sub ReNameFiles(ByVal myDir As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String, newName As String
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        If myFile.Name Like "*_A_*" Then
            newName = ExecuteExcel4Macro("right(substitute('" & myDir & "\[" & myFile.Name & "]sheet1'!r5c1,""/"",""""),8)")
            temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                    "." & sfo.GetExtensionName(myFile.Name)
            Name myDir & "\" & myFile.Name As myDir & "\" & temp
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path
    Next
End Sub
 
Hi jindon, thanks for the quick reply.

The code stopped working after replacing the first file name and returning with no. 13 "type mismatch" error(Type13.jpg). Also, I just noticed a small number of the files placed the Date in A4 (Abnormal.jpg) instead of A5 (normal.jpg).

Is there a way to scan row 4 to 5 and extract the desired info. when the cell contains numbers or the word "Date"? Thanks!
 

Attachments

  • Normal.JPG
    Normal.JPG
    11.7 KB · Views: 7
  • Type13.JPG
    Type13.JPG
    25.3 KB · Views: 8
  • Abnormal.JPG
    Abnormal.JPG
    12.9 KB · Views: 6
This will check A4 and A5.
It will change the file name only when one of above contains date at the end.
Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir
End Sub

Sub ReNameFiles(ByVal myDir As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String, newName As String, i As Long
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        If myFile.Name Like "*_A_*" Then
            For i = 4 To 5
                newName = ExecuteExcel4Macro("right(substitute('" & myDir & "\[" & myFile.Name & "]sheet1'!r" & i & "c1,""/"",""""),8)")
                If (newName <> vbNullString) * (IsNumeric(newName)) Then
                    temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                            "." & sfo.GetExtensionName(myFile.Name)
                    Name myDir & "\" & myFile.Name As myDir & "\" & temp
                End If
                Exit For
            Next
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path
    Next
End Sub
 
This will check A4 and A5.
It will change the file name only when one of above contains date at the end.
Code:
Sub test()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = vbNullString Then Exit Sub
    ReNameFiles myDir
End Sub

Sub ReNameFiles(ByVal myDir As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String, newName As String, i As Long
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        If myFile.Name Like "*_A_*" Then
            For i = 4 To 5
                newName = ExecuteExcel4Macro("right(substitute('" & myDir & "\[" & myFile.Name & "]sheet1'!r" & i & "c1,""/"",""""),8)")
                If (newName <> vbNullString) * (IsNumeric(newName)) Then
                    temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                            "." & sfo.GetExtensionName(myFile.Name)
                    Name myDir & "\" & myFile.Name As myDir & "\" & temp
                End If
                Exit For
            Next
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path
    Next
End Sub

Thanks jindon, I just tried it and I got an error 13 again. This time, no file name is changed. My office version is 2010, is there something to do with it? Or some other system setting?
Type13_01.JPG
 
Error 13? Type mismatch?

Run it again and read newName when it stops.
Move the cursor on to the variable and you can read it.
 
Most probably the cell contains Error value.
Replace ReNameFiles sub procedure with the following code and see how it runs.
Code:
Sub ReNameFiles(ByVal myDir As String)
    Dim sfo As Object, myFile As Object, myFolder As Object, temp As String, newName, i As Long
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each myFile In sfo.GetFolder(myDir).Files
        If myFile.Name Like "*_A_*" Then
            For i = 4 To 5
                newName = ExecuteExcel4Macro("right(substitute('" & myDir & "\[" & myFile.Name & "]sheet1'!r" & i & "c1,""/"",""""),8)")
                If (Not IsError(newName)) Then
                    If (newName <> vbNullString) * (IsNumeric(newName)) Then
                        temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                                "." & sfo.GetExtensionName(myFile.Name)
                        Name myDir & "\" & myFile.Name As myDir & "\" & temp
                        Exit For
                    End If
                End If
            Next
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path
    Next
End Sub
 
Back
Top