Rename file after move to subfolder

[Nguyen Anh Dung]

i have code as below. after move file to subfolder. Help me rename file.

example: i move list file to folder 20200921_22_014_TPThuanAn_BD_GS103997
20200921_22_014_TPThuanAn_BD_GS103997004.jpg
20200921_22_014_TPThuanAn_BD_GS103997003.jpg
20200921_22_014_TPThuanAn_BD_GS103997002.jpg
20200921_22_014_TPThuanAn_BD_GS103997001.jpg
20200921_22_014_TPThuanAn_BD_GS103997000.jpg

after move finish i want rename file as below picture:

Public Sub Move_Files()

    Dim sourceFolder As String, fileName As String
    Dim destinationFolder As String, foundDestinationFolder As String
    Dim missingFolders As String
    On Error Resume Next
    'sourceFolder = "D:\Vidu\"
    sourceFolder = Application.InputBox("Nhap duong dan: ")
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    
    'Loop through *.xls files in source folder
    
    missingFolders = ""
    fileName = Dir(sourceFolder & "*.jpg")
    While fileName <> vbNullString
        If Right(fileName, 4) = ".jpg" Then
            destinationFolder = Left(fileName, InStrRev(fileName, "GS") + 7)
            'destinationFolder = Left(fileName, Len(fileName) - 7)
            foundDestinationFolder = Find_Subfolder(sourceFolder, destinationFolder)
            If foundDestinationFolder <> "" Then
                Name sourceFolder & fileName As foundDestinationFolder & fileName
            Else
                missingFolders = missingFolders & vbCrLf & destinationFolder
            End If
        End If
        fileName = Dir
    Wend
    
    If missingFolders = "" Then
        MsgBox "Tat Ca Folder exist.  All files moved to their respective destination folder"
    Else
         MsgBox "Folder Khong Ton Tai" & vbCrLf & _
                missingFolders
    End If

End Sub



Private Function Find_Subfolder(folderPath As String, subfolderName As String) As String

    Static FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object
    
    'Traverse subfolders from a folder path and return when matching folder name found
    
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set FSfolder = FSO.GetFolder(folderPath)
     
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.SubFolders
        If UCase(FSsubfolder.Name) = UCase(subfolderName) Then
            Find_Subfolder = FSsubfolder.path & "\"
        Else
            Find_Subfolder = Find_Subfolder(FSsubfolder.path, subfolderName)
        End If
        If Find_Subfolder <> "" Then Exit For
    Next
    
End Function

Thanks all and Best regards!!!

 

[Yongle]

How about doing both at once

Name sourceFolder & oldFileName As foundDestinationFolder & newFileName

 

[Nguyen Anh Dung]

How about doing both at once

Name sourceFolder & oldFileName As foundDestinationFolder & newFileName

I have change but not doing!!!
thanks you!!!

 

[Yongle]

It works - I tested it
Post your amended code in full

 

[Nguyen Anh Dung]

How about doing both at once

Name sourceFolder & oldFileName As foundDestinationFolder & newFileName

i change code run ok!!!

NewFileName = Mid(fileName, InStr(fileName, "GS"), Len(fileName))
Name sourceFolder & fileName As foundDestinationFolder & NewFileName

Thanks you and best regards!!!

 

[Nguyen Anh Dung]

It works - I tested it
Post your amended code in full

Help me in this case: filename 20200922_01_011_GSM_GS020195000. i want to find the last "GS"

 

[Yongle]

Please start a new thread for your new question