Copying files into folders with their respective names

[nmkhan3010]

Hi,

In a folder am having more than 600 files and common is first 8 numbers and I need to create a folder with the name “ XXXXXXXX_Vietnamese_Live_XID” and need to copy all the files related to that first 8 numbers in that folder.

Please help me in this regard and I have tried but not getting, please check and do the needful ASAP.

Source data: PFA 1 (Capture 1)

Output data: PFA 2 & PFA 3 (Capture 2 & Capture 3).


MY CODE :

Sub LoopAllFilesInAFolder()



'Loop through all files in a folder

Dim fileName As Variant, path As String

fileName = Dir("C:\Robot\TEXTDOC\TEST\\")

path = "C:\Robot\TEXTDOC\TEST\"

While fileName <> ""



If fileName Like "*_XID*" Then



MkDir path & Left(fileName, InStr(fileName, ".") - 1)

End If





fileName = Dir

Wend

Call Move_Files

End Sub





Public Sub Move_Files()



Dim sourceFolder As String, fileName As String

Dim destinationFolder As String, foundDestinationFolder As String

Dim missingFolders As String

Dim Extension As String

sourceFolder = "C:\Robot\TEXTDOC\TEST\"

If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"



'Loop through *.xls files in source folder



missingFolders = ""

fileName = Dir(sourceFolder)



If fileName Like "*_XID*" Then



Extension = fileName

End If







While fileName <> vbNullString





'destinationFolder = Left(fileName, InStrRev(fileName, ".") - 1)

destinationFolder = Left(fileName, 8) & "_Vietnamese_Live_XID"







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

 

[juddaaaa]

This one function should do everything you need

Sub FolderizeFiles()

    Dim fso As Object, fldr As Object, subFldr As Object, fle As Object
    Dim fldrNew As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder("C:\Robot\TEXTDOC\TEST")
        
    For Each fle In fldr.Files
        If Right(fso.GetBaseName(fle), 3) = "XID" Then
            fldrNew = fldr.path & "\" & fso.GetBaseName(fle)
        
            If Not fso.FolderExists(fldrNew) Then
                fso.CreateFolder fldrNew
            End If
            
            fso.MoveFile _
                Source:=fle.path, _
                Destination:=fldrNew & "\" & fle.Name
        End If
    Next fle
    
    For Each fle In fldr.Files
        For Each subFldr In fldr.SubFolders
            If Left(subFldr.Name, 8) = Left(fle.Name, 8) Then
                fso.MoveFile _
                    Source:=fle.path, _
                    Destination:=subFldr.path & "\" & fle.Name
                Exit For
            End If
        Next subFldr
    Next fle

End Sub

 

[nmkhan3010]

Thank You So Much....
You Did Awesome JOB.....