PDA

View Full Version : Help to moving file to another folder, using partial filename



Muthukumar27
12-16-2020, 11:31 PM
Hi Friends, I got this below code which help to move the files with specific names from same folder to specific same name folder.


Now I'm facing issues wherein the file name has additional text such as "Mumbai_1", "Mumbai_ABC", "Mumbai_ICC" etc which also need to be moved to Folder with Name "Mumbai"



Public Sub Move_Files()
Dim sourceFolder As String, fileName As String
Dim destinationFolder As String, foundDestinationFolder As String
Dim missingFolders As String

sourceFolder = "D:File WorkFile moverSource"
If Right(sourceFolder, 1) <> "" Then sourceFolder = sourceFolder & ""

'Loop through *.xls files in source folder
missingFolders = ""
fileName = Dir(sourceFolder & "*.pdf")
While fileName <> vbNullString
If Right(fileName, 4) = ".pdf" Then
destinationFolder = Left(fileName, InStrRev(fileName, ".") - 1)
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 "All subfolders exist. All files moved to their respective destination folder"
Else
MsgBox "The following subfolders don't exist:" & 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