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

jindon · Dec 9, 2016

Check the cells in unchanged workbook and give me the exact contents in the cell.

It is working just fine here.

Winston618 · Dec 9, 2016

jindon said:
Check the cells in unchanged workbook and give me the exact contents in the cell.

It is working just fine here.

I am suspecting that the file I got from the company portal is not real XLS, it seems they just named .xls but it's something else. Because files that can be renamed by the VBA are those I made modification before. A colleague once told me that those "xls" could be just xml.

I tried to open a number of files, press Save and exit without change. Run the VBA again, they all start working.

Winston618 · Dec 9, 2016

Is there a way to get around this without saving every file once?

jindon · Dec 10, 2016

try

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, 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 Exit For
                End If
            Next
            If IsError(newName) Then newName = GetDate(myDir & "\" & myFile.Name)
            If newName <> "" Then
                newName = Replace(newName, "/", "")
                temp = Left$(sfo.GetBaseName(myFile.Name), 10) & newName & _
                                "." & sfo.GetExtensionName(myFile.Name)
                Name myDir & "\" & myFile.Name As myDir & "\" & temp
            End If
            newName = ""
        End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).SubFolders
        ReNameFiles myFolder.Path
    Next
End Sub

Function GetDate(fn As String) As String
    Dim txt As String
    txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
    With CreateObject("VBScript.RegExp")
        .Pattern = "Transaction Date .+to ([^<]+)"
        If .test(txt) Then GetDate = .Execute(txt)(0).submatches(0)
    End With
End Function

Winston618 · Dec 10, 2016

jindon, i tried it, no error prompted and no change is made.

My colleague and I mingled your code for a several hours and finally got it working. It's a bit clumsy so feel free to comment.

Our idea is to break the vba into two parts, first is to save and close each file in the folders and subfolders for one time. The second part is to scan the content of each file and rename that file.

Thanks for all your help!

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
    ReSaveFiles myDir
    'MsgBox ("Done Part 1")
    ReNameFilesOriginal myDir
    'MsgBox ("Done Part 2")
End Sub

Sub ReSaveFiles(ByVal myDir As String)
    Dim sfo As Object, MyFile As Object, myFolder As Object, temp As String, newName, i As Long, filestr As String
    Dim daily_wk As Workbook
   
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each MyFile In sfo.GetFolder(myDir).Files
        If MyFile.Name Like "*_A_*" Then
        Filename = myDir + "\" + MyFile.Name
        Workbooks.Open Filename
        Windows(MyFile.Name).Activate
        ActiveWorkbook.Save
        ActiveWorkbook.Close Savechanges:=True
        'MsgBox (Filename)
        End If
    Next
    'Stop
    For Each myFolder In sfo.GetFolder(myDir).subfolders
        ReSaveFiles myFolder.Path
    Next

End Sub

Sub ReNameFilesOriginal(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
        ReNameFilesOriginal myFolder.Path
    Next

   
End Sub

jindon · Dec 10, 2016

If is is working, no comment.

Winston618 · Dec 11, 2016

Hi jindon, the code works fine but many old files are mishandled by predecessors, the files are added a blank column A; therefore, no value is returned during the scan thus no changed can be made.

Is it possible to add a searching rule to check if column A is empty? If A is empyt, then check the same rows in column B? Thank you.

jindon · Dec 12, 2016

Try my last code again.

Winston618 · Dec 12, 2016

jindon said:
Try my last code again.

Hi, just tried it a couple times, doesn't seem to work when the date is on either B4/B5.

jindon · Dec 12, 2016

What about the file comes from xml?

If the file is originally xml, it should change the file name without opening.

Winston618 · Dec 12, 2016

jindon said:
What about the file comes from xml?

If the file is originally xml, it should change the file name without opening.

No effect, it must be something other than xml.

jindon · Dec 12, 2016

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
    Application.ScreenUpdating = False
    SearchFiles myDir
    Application.ScreenUpdating = True
End Sub

Sub SearchFiles(ByVal myDir As String)
    Dim a() As String, sfo As Object, MyFile As Object
    Dim myFolder As Object, newName, r As Range, i As Long, n As Long
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each MyFile In sfo.GetFolder(myDir).Files
        If MyFile.Name Like "*_A_*" Then
            With Workbooks.Open(myDir & "\" & MyFile.Name).Sheets("sheet1")
                .Parent.Save
                For Each r In .Range("a4:b5")
                    newName = Right$(Replace(r.Value, "/", ""), 8)
                    If (newName <> "") * (IsNumeric(newName)) Then
                        n = n + 1
                        ReDim Preserve a(1 To 2, 1 To n)
                        a(1, n) = myDir & "\" & MyFile.Name
                        a(2, n) = myDir & "\" & Left$(sfo.GetBaseName(MyFile.Name), 10) & _
                                newName & "." & sfo.GetExtensionName(MyFile.Name)
                        Exit For
                    End If
                Next
                .Parent.Close False
            End With
       End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).subfolders
        SearchFiles myFolder.Path
    Next
    If n > 0 Then
        For i = 1 To n
            Name a(1, i) As a(2, i)
        Next
    End If
End Sub

Winston618 · Dec 14, 2016

jindon said:

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
    Application.ScreenUpdating = False
    SearchFiles myDir
    Application.ScreenUpdating = True
End Sub

Sub SearchFiles(ByVal myDir As String)
    Dim a() As String, sfo As Object, MyFile As Object
    Dim myFolder As Object, newName, r As Range, i As Long, n As Long
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each MyFile In sfo.GetFolder(myDir).Files
        If MyFile.Name Like "*_A_*" Then
            With Workbooks.Open(myDir & "\" & MyFile.Name).Sheets("sheet1")
                .Parent.Save
                For Each r In .Range("a4:b5")
                    newName = Right$(Replace(r.Value, "/", ""), 8)
                    If (newName <> "") * (IsNumeric(newName)) Then
                        n = n + 1
                        ReDim Preserve a(1 To 2, 1 To n)
                        a(1, n) = myDir & "\" & MyFile.Name
                        a(2, n) = myDir & "\" & Left$(sfo.GetBaseName(MyFile.Name), 10) & _
                                newName & "." & sfo.GetExtensionName(MyFile.Name)
                        Exit For
                    End If
                Next
                .Parent.Close False
            End With
       End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).subfolders
        SearchFiles myFolder.Path
    Next
    If n > 0 Then
        For i = 1 To n
            Name a(1, i) As a(2, i)
        Next
    End If
End Sub

Hi, jindon

The follow code at the bottom of the vba receives an Error 53: File not found, but all the files are renamed.

Code:

 Name a(1,i) As a(2,i) &

Winston618 · Dec 16, 2016

Winston618 said:
Hi, jindon

The follow code at the bottom of the vba receives an Error 53: File not found, but all the files are renamed.

Code:

Name a(1,i) As a(2,i)

Hi jindon,

More finding on this "file not found" error, when it was renaming files in multiple folders. The error shown on the last file in the first file. When it was trying to rename files in a single layer folder, the error shown on the last file. Thanks.

jindon · Dec 16, 2016

Since I can not test the code for myself, no more idea.

Winston618 · Dec 17, 2016

Hi jindon,

Here are the files and code for you to test with.

The following is the code that I have been tweaking with. Besides file with *_A_*, I was also trying to rename files that started with: NCIR024_D_YMT_, NCIR024_D_YMT_B_, and NCIR024_D_YMT_E_ as well.

But I couldn't get it to work without receiving the "file not found" error, please feel free to comment. Thank you.

Code:

Sub test121716()
    Dim myDir As String
    With Application.FileDialog(msoFileDialogFolderPicker)
          If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = vbNullString Then Exit Sub
    'Application.ScreenUpdating = False
    SearchFiles myDir
       
    'Application.ScreenUpdating = True
    'Call Shell("explorer.exe" & " " & myDir, vbNormalFocus)
End Sub

Sub SearchFiles(ByVal myDir As String)
    Dim a() As String, sfo As Object, MyFile As Object
    Dim myFolder As Object, newName, r As Range, i As Long, n As Long
    Set sfo = CreateObject("Scripting.FileSystemObject")
    For Each MyFile In sfo.GetFolder(myDir).Files
        If MyFile.Name Like "NCIR*" Then
            With Workbooks.Open(myDir & "\" & MyFile.Name).Sheets("sheet1")
                .Parent.Save
                For Each r In .Range("a4:b5")
                    newName = Right$(Replace(r.Value, "/", ""), 8)
                    If (newName <> "") * (IsNumeric(newName)) Then
                        n = n + 1
                        'ReDim Preserve a(1 To 2, 1 To n)
                       
                        '''Test
                                    If MyFile.Name Like "*_A_*" Then
                                    ReDim Preserve a(1 To 2, 1 To n)
                                    a(1, n) = myDir & "\" & MyFile.Name
                                    a(2, n) = myDir & "\" & Left$(sfo.GetBaseName(MyFile.Name), 10) & _
                                            newName & "." & sfo.GetExtensionName(MyFile.Name)
                                    End If
                                   
                                    If MyFile.Name Like "*_YMT_20*" Then
                                    ReDim Preserve a(1 To 2, 1 To n)
                                    a(1, n) = myDir & "\" & MyFile.Name
                                    a(2, n) = myDir & "\" & Left$(sfo.GetBaseName(MyFile.Name), 14) & _
                                            newName & "." & sfo.GetExtensionName(MyFile.Name)
                                    End If

                                    If MyFile.Name Like "*_YMT_*_*_*" Then
                                    ReDim Preserve a(1 To 2, 1 To n)
                                    a(1, n) = myDir & "\" & MyFile.Name
                                    a(2, n) = myDir & "\" & Left$(sfo.GetBaseName(MyFile.Name), 16) & _
                                            newName & "." & sfo.GetExtensionName(MyFile.Name)
                                    End If
                        '''Test
                        Exit For
                        End If
                Next
                .Parent.Close False
            End With
       End If
    Next
    For Each myFolder In sfo.GetFolder(myDir).subfolders
        SearchFiles myFolder.Path
    Next
    If n > 0 Then
        For i = 1 To n
            Name a(1, i) As a(2, i)
        Next
   End If
End Sub

jindon · Dec 17, 2016

Is my code working or not?

If you are talking about different code other than I have posted, no way to find out the problem.

I'm getting tired.

Winston618 · Dec 19, 2016

The last code you wrote is working great, thank you for all the help, it gets me very close to where I want to be.

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

jindon

Well-Known Member

Winston618

Member

Winston618

Member

jindon

Well-Known Member

Winston618

Member

jindon

Well-Known Member

Winston618

Member

jindon

Well-Known Member

Winston618

Member

jindon

Well-Known Member

Winston618

Member

jindon

Well-Known Member

Winston618

Member

Winston618

Member

jindon

Well-Known Member

Winston618

Member

Attachments

jindon

Well-Known Member

Winston618

Member