Nguyen Anh Dung
Board Regular
- Joined
- Feb 28, 2020
- Messages
- 180
- Office Version
- 2016
- Platform
- Windows
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:
Thanks all and Best regards!!!
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:
Code:
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!!!