Move files based on specific words location in new folders

Hello
I'm new here , and searched too much in the internet to getting what I want, but still nothing until now .
I have files in this device C:\Users\MSS\Desktop\ABSI like this
C:\Users\MSS\Desktop\ABSI\APPVD INV10000A-00.xlsb
C:\Users\MSS\Desktop\ABSI\EXTRA\CCVB AAAA100 200A.xlsm
C:\Users\MSS\Desktop\ABSI\EXTRA\SSSSVB REP_222AQ12.pdf
what I wan:
1- create folder in main folder "ABSI " based on current year like this YEAR_2025 to become directory C:\Users\MSS\Desktop\ABSI\YEAR_2025
2- create folders based on first part is existed in file name and put inside YEAR_2025 folder like this PPVD,CCVB,SSSSVB and ignore files names don't contain theses three words become directory C:\Users\MSS\Desktop\ABSI\YEAR_2025\PPVD
C:\Users\MSS\Desktop\ABSI\YEAR_2025\CCVB
C:\Users\MSS\Desktop\ABSI\YEAR_2025\SSSSVB
3- create folders inside folders PPVD,CCVB,SSSSVB based on current month like this
EXTRACTION_JAN , EXTRACTION_FEB and so on to become directory like this
C:\Users\MSS\Desktop\ABSI\YEAR_2025\PPVD\EXTRACTION_JAN
C:\Users\MSS\Desktop\ABSI\YEAR_2025\PPVD\EXTRACTION_FEB
4- move files from directory to folders EXTRACTION_JAN , EXTRACTION_FEB based on first part within folders PPVD,CCVB,SSSSVB based on current month and current year.
like this
C:\Users\MSS\Desktop\ABSI\YEAR_2025\PPVD\EXTRACTION_JAN\APPVD INV10000A-00.xlsb
so should moves files from folders and subfolders and sub - subfolders.
thanks.

You are asking for a lot of code to be created. Have you made any attempt?

You want code to create file structure as well as move files?

How do you know which year and month file should go into?

Start with understanding code that loops through files.
Review
http://allenbrowne.com/ser-59.html
https://exceloffthegrid.com/vba-code...r-sub-folders/

Quote:

---

You are asking for a lot of code to be created.

---

I know it's not to easy to do that with all of requirements.

Quote:

---

Have you made any attempt?

---

not yet , I'm still search for something close .

Quote:

---

How do you know which year and month file should go into?

---

every file will contains modified date for properties .

Quote:

---

Start with understanding code that loops through files.

---

I will see if I don't get anything from the internet.

If you want the month folders to list chronologically, need to use month number instead of month name, or use both - like:
EXTRACTION_Mon01_JAN

Here's some code specific to your requirements for you to check out. Set a reference to the Microsoft Scripting Runtime library for the FileSystemObject coding.

Code:

---

Sub MoveFiles()
Dim sMain As String, sFile As String, fFolder As Object, FSO As FileSystemObjectDim dicDirList As New Dictionary
Dim varItem As Variant
'sMain = "C:\Users\MSS\Desktop\ABSI"
sMain = "C:\Users\Administrator\Desktop\ABSI"
If Dir(sMain, vbDirectory) = "" Then
    MsgBox "Folder does not exist"
Else
    If Dir(sMain & "\Year_" & Year(Date), vbDirectory) = "" Then MkDir sMain & "\Year_" & Year(Date)
    If Dir(sMain & "\Year_" & Year(Date) & "\APPVD", vbDirectory) = "" Then MkDir sMain & "\Year_" & Year(Date) & "\APPVD"
    If Dir(sMain & "\Year_" & Year(Date) & "\CCVB", vbDirectory) = "" Then MkDir sMain & "\Year_" & Year(Date) & "\CCVB"
    If Dir(sMain & "\Year_" & Year(Date) & "\SSSSVB", vbDirectory) = "" Then MkDir sMain & "\Year_" & Year(Date) & "\SSSSVB"
    Call FillDir(dicDirList, sMain, "", True)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each varItem In dicDirList.keys
        Debug.Print varItem, dicDirList(varItem)
        'Copy file
        If Dir(sMain & "\Year_" & Year(Date) & dicDirList(varItem), vbDirectory) = "" Then MkDir sMain & "\Year_" & Year(Date) & dicDirList(varItem)
        FSO.CopyFile varItem, sMain & "\Year_" & Year(Date) & dicDirList(varItem) & "\"
    Next
End If
End Sub


Private Function FillDir(dicDirList As Dictionary, ByVal strFolder As String, strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    'Build up a list of files, and then add to this list, any additional folders
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant, oFile As Object, oFolder As folder, FSO As New FileSystemObject
    Dim strKey As String


    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(strFolder)
    If Not oFolder.Name Like "Year_" Then
        For Each oFile In oFolder.Files
            dicDirList.Add oFolder.Path & "\" & oFile.Name, _
                      "\" & Left(oFile.Name, InStr(oFile.Name, " ") - 1) & "\EXTRACTION_Mon" & Format(oFile.DateLastModified, "mm_mmm")
        Next
    End If
   
    If bIncludeSubfolders Then
        'Build collection of additional subfolders.
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    If Not oFolder.Name Like "*Year_*" Then colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        'Call function recursively for each subfolder.
        For Each vFolderName In colFolders
            Call FillDir(dicDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If

End Function

Public Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function

---

Maybe this will get you started?

Code:

---

Sub ProcessFiles(ByVal strFolderPath As String, ByRef objFSO As Object, ByVal strYearFolder As String, ByVal currentMonth As String)
    Dim strFile As String
    Dim strFileTypePrefix As String
    Dim strMonthFolder As String
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim strSourceFilePath As String
    Dim strDestFilePath As String
    ' Get the folder object
    Set objFolder = objFSO.GetFolder(strFolderPath)
    ' Loop through each file in the current folder.
    For Each strFile In objFolder.Files
        ' Get the file type prefix (first part of the filename).
        strFileTypePrefix = GetFileTypePrefix(objFSO.GetFileName(strFile))
        ' Check if the file type prefix is one of the desired types.
        If strFileTypePrefix = "APPVD" Or strFileTypePrefix = "CCVB" Or strFileTypePrefix = "SSSSVB" Then
            ' Create the file type folder if it doesn't exist.
            If Dir(strYearFolder & "\" & strFileTypePrefix, vbDirectory) = "" Then
                MkDir strYearFolder & "\" & strFileTypePrefix
                Debug.Print "Created folder: " & strYearFolder & "\" & strFileTypePrefix
            Else
                Debug.Print "Folder already exists: " & strYearFolder & "\" & strFileTypePrefix
            End If
            ' Create the month folder if it doesn't exist.
            strMonthFolder = strYearFolder & "\" & strFileTypePrefix & "\" & currentMonth
            If Dir(strMonthFolder, vbDirectory) = "" Then
                MkDir strMonthFolder
                Debug.Print "Created folder: " & strMonthFolder
            Else
                  Debug.Print "Folder already exists: " & strMonthFolder
            End If
            ' Move the file to the month folder.
            strSourceFilePath = strFolderPath & "\" & objFSO.GetFileName(strFile)
            strDestFilePath = strMonthFolder & "\" & objFSO.GetFileName(strFile)
            objFSO.MoveFile strSourceFilePath, strDestFilePath
            Debug.Print "Moved file: " & strSourceFilePath & " to " & strDestFilePath
        End If
    Next strFile
    ' Recursively process subfolders.
    For Each objSubFolder In objFolder.SubFolders
        ProcessFiles objSubFolder.Path, objFSO, strYearFolder, currentMonth
    Next objSubFolder
End Sub
 
Function GetFileTypePrefix(ByVal strFileName As String) As String
    ' Returns the first part of the filename before the first space or hyphen.
    Dim i As Long
    i = InStr(1, strFileName, " ")
    If i > 0 Then
        GetFileTypePrefix = Left(strFileName, i - 1)
    Else
        i = InStr(1, strFileName, "-")
        If i > 0 Then
            GetFileTypePrefix = Left(strFileName, i - 1)
        Else
            GetFileTypePrefix = strFileName
        End If
    End If
End Function

---

I will check your suggestions guys, but the web doesn't work most all of times through day !
that's why I delayed to see your posts.

June7

shows me error invalid procedure call or argument in this line

Code:

---

dicDirList.Add oFolder.Path & "\" & oFile.Name, _
                      "\" & Left(oFile.Name, InStr(oFile.Name, " ") - 1) & "\EXTRACTION_Mon" & Format(oFile.DateLastModified, "mm_mmm")

---

by the way you have syntax error in this part

Code:

---

Dim sMain As String, sFile As String, fFolder As Object, FSO As FileSystemObjectDim dicDirList As New Dictionary

---

should be

Code:

---

Dim sMain As String, sFile As String, fFolder As Object, FSO As FileSystemObject, dicDirList As New Dictionary

---

There's something familiar with the posting style of Mussa and Kalil......

Quote:

---

Maybe this will get you started?

---

How run your code?

Don't know how that declaration got messed up in post. This is how it is in my code:

Code:

---

Dim sMain As String, sFile As String, fFolder As Object, FSO As FileSystemObject
Dim dicDirList As New Dictionary
Dim varItem As Variant

---

The dicDirList.Add line is exactly what I have and it works.

you can try this

Code:

---

Option Explicit


Const cLevel1 As String = "C:\Users\Daddy\Desktop\ABSI\"  '  <<<<<<<<<<<<< change


Sub MakeFolderTree()
    Dim aryLevel1 As Variant, aryLevel2 As Variant, aryLevel3 As Variant
    Dim i1 As Long, i2 As Long, i3 As Long
    Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath1a As String
    Dim sFile As String, sOldName As String, sNewName As String
    Dim sYear As String, sMonth As String
   
    'setup folders
    aryLevel1 = Split(cLevel1, Application.PathSeparator)
    aryLevel2 = Array("PPVD", "CCVB", "SSSSVB")
    aryLevel3 = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")


    sYear = "YEAR_" & Year(Now)
    sMonth = UCase(Format(Now, "mmm"))




    'make top level is needed
    sPath1 = aryLevel1(LBound(aryLevel1))
    For i1 = LBound(aryLevel1) + 1 To UBound(aryLevel1)
        On Error Resume Next
        MkDir sPath1
        sPath1 = sPath1 & Application.PathSeparator & aryLevel1(i1)
        On Error GoTo 0
    Next i1
   
    sPath1a = sPath1 & sYear & Application.PathSeparator
   
   
    'make next 2 levels if needed
    For i2 = LBound(aryLevel2) To UBound(aryLevel2)
        sPath2 = sPath1 & aryLevel2(i2)
       
        On Error Resume Next
        MkDir sPath2
        On Error GoTo 0


        'make level 3
        For i3 = LBound(aryLevel3) To UBound(aryLevel3)
            sPath3 = sPath2 & Application.PathSeparator & "EXTRACTION_" & aryLevel3(i3)
       
            On Error Resume Next
            MkDir sPath3
            On Error GoTo 0
        Next i3
       
    Next i2


    'read files in top level sPath1 and move
    'C:\Users\MSS\Desktop\ABSI\APPVD INV10000A-00.xlsb
    sFile = Dir(sPath1)


    Do While Len(sFile) > 0
        For i2 = LBound(aryLevel2) To UBound(aryLevel2)
            If InStr(sFile, aryLevel2(i2)) > 0 Then
                sOldName = sPath1 & sFile
                sNewName = cLevel1 & aryLevel2(i2) & Application.PathSeparator & "EXTRACTION_" & UCase(Format(Now, "mmm")) & Application.PathSeparator & sFile
              Debug.Print sOldName & " ---> " & sNewName
              Name sOldName As sNewName
            End If
        Next i2
       
        sFile = Dir
    Loop


    'C:\Users\MSS\Desktop\ABSI\EXTRA\CCVB AAAA100 200A.xlsm
    'C:\Users\MSS\Desktop\ABSI\EXTRA\SSSSVB REP_222AQ12.pdf
    sFile = Dir(sPath1 & "EXTRA\")
   
    Do While Len(sFile) > 0
        For i2 = LBound(aryLevel2) To UBound(aryLevel2)
            If InStr(sFile, aryLevel2(i2)) > 0 Then
                sOldName = sPath1 & "EXTRA\" & sFile
                sNewName = cLevel1 & aryLevel2(i2) & Application.PathSeparator & "EXTRACTION_" & UCase(Format(Now, "mmm")) & Application.PathSeparator & sFile
           
                Debug.Print sOldName & " ---> " & sNewName
                Name sOldName As sNewName
            End If
        Next i2
       
        sFile = Dir
    Loop
End Sub

---

Hi Paul,
I'm not sure why shows error file is not found !

Code:

---

Name sOldName As sNewName

---

June7
when test with 2010 version shows me error bad file name or number !

Code:

---

If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then

---

I wrote and tested code with Excel 2010.

GetAttr() Is an intrinsic function https://learn.microsoft.com/en-us/of...tattr-function. That line comes from Allen Browne's code http://allenbrowne.com/ser-59.html. I did drop & character he shows because I thought it was a typo although seems to work with it as well.

Don't know why you get "bad file name or number" error. You will have to debug your code. Do variables have correct values?

Quote:

---

Originally Posted by Mussa

Hi Paul,
I'm not sure why shows error file is not found !

Code:

---

Name sOldName As sNewName

---

---

Did you change this?

Code:

---

Const cLevel1 As String = "C:\Users\Daddy\Desktop\ABSI\"  '  <<<<<<<<<<<<< change

---

What does the Debug window say?

Code:

---

Debug.Print sOldName & " ---> " & sNewName

---

try

Code:

---

Sub test()
    Dim myDir$, e, msg$, myFile As Object, fso As Object, dic As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dic = CreateObject("Scripting.Dictionary")
    myDir = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\ABSI"
    For Each e In Array("APPVD INV10000A-00.xlsb", "EXTRA\CCVB AAAA100 200A.xlsm", _
            "EXTRA\SSSSVB REP_222AQ12.pdf")
        If Dir(myDir & "\" & e) <> "" Then
            Set myFile = fso.GetFile(myDir & "\" & e)
            dic(myDir & "\" & e) = Join(Array(myDir, "YEAR_" & Year(myFile.DateLastModified), _
                Split(myFile.Name)(0), "EXTRACTION_" & Choose(Month(myFile.DateLastModified), _
                "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", _
                "DEC"), myFile.Name), "\")
        End If
    Next
    If dic.Count = 0 Then MsgBox "No file to move": Exit Sub
    For Each e In dic
        If IsFileOpen(e) Then
            msg = msg & vbLf & e
        Else
            Call CheckFolder(dic(e))
            Name e As dic(e)
        End If
    Next
    If Len(msg) Then MsgBox "Following file(s) is/are currently open" & vbLf & msg, , "Try again later"
End Sub


Function IsFileOpen(ByVal fName$) As Boolean
    Dim ff&, errNum&
    On Error Resume Next
    ff = FreeFile
    Open fName For Input Lock Read As #ff
    Close ff
    errNum = Err
    On Error GoTo 0
    IsFileOpen = (errNum <> 0)
End Function


Function CheckFolder(x)
    Dim i&, f$
    x = Split(x, "\")
    For i = 0 To UBound(x) - 1
        f = f & IIf(f = "", "", "\") & x(i)
        If Dir(f & "\", vbDirectory) = "" Then MkDir f
    Next
End Function

---

Paul,
yes I made sure the directory .
for sOldName show me file in directory
for sNewName show new directory by move file to EXTRACTION_MAY folder to within folder PPVD but because of the error will not move to EXTRACTION_MAY folder!

Hi jindon,
I think you misunderstood my requirements !
I see you specify specific files names , but what I want to move many files contains parts of names ("PPVD", "CCVB", "SSSSVB") when find these parts then move otherwise ignore others files from moving.

Then

Code:

---

Sub test()
    Dim myDir$, x, myList(), i&, msg$
    myDir = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\ABSI"
    x = SearchFiles(myDir, "* *.*", 0, myList, myDir)
    If IsEmpty(x) Then MsgBox "No file found": Exit Sub
    For i = 1 To UBound(x, 2)
        If myList(1, i) <> myList(2, i) Then
            If Not IsFileOpen(x(1, i)) Then
                Call CheckFolder(x(2, i))
                Name x(1, i) As x(2, i)
            Else
                msg = msg & vbLf & x(1, i)
            End If
        End If
    Next
    If Len(msg) Then MsgBox "Follwing file(s) is/are currently in use", vbInformation, "Try later"
End Sub


Function SearchFiles(fPath$, myFileName$, n&, myList(), myDir) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.GetFolder(fPath).Files
        If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
        * (myFile.Name Like myFileName) Then
            n = n + 1
            ReDim Preserve myList(1 To 2, 1 To n)
            myList(1, n) = myFile.Path
            myList(2, n) = Join(Array(myDir, "YEAR_" & Year(myFile.DateLastModified), _
                Split(fso.GetBaseName(myFile.Name))(0), "EXTRACTION_" & _
                Choose(Month(myFile.DateLastModified), _
                "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", _
                "DEC"), myFile.Name), "\")
        End If
    Next
    For Each myFolder In fso.GetFolder(fPath).SubFolders
        SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList, myDir)
    Next
    SearchFiles = myList
End Function


Function IsFileOpen(ByVal fName$) As Boolean
    Dim ff&, errNum&
    On Error Resume Next
    ff = FreeFile
    Open fName For Input Lock Read As #ff
    Close ff
    errNum = Err
    On Error GoTo 0
    IsFileOpen = (errNum <> 0)
End Function


Function CheckFolder(ByVal x)
    Dim i&, f$
    x = Split(x, "\")
    For i = 0 To UBound(x) - 1
        f = f & IIf(f = "", "", "\") & x(i)
        If Dir(f & "\", vbDirectory) = "" Then MkDir f
    Next
End Function

---

thank jindon your cod works excellently , but just I would move files based on words theses
("PPVD", "CCVB", "SSSSVB") as I mentioned

Quote:

---

and ignore files names don't contain theses three words

---

Quote:

---

otherwise ignore others files from moving.

---

so any file doesn't move within Year_2025 if doesn't contain words ("PPVD", "CCVB", "SSSSVB")

Replace "test" & "SearchFiles" procedures with below

Code:

---

Sub test()
    Dim myDir$, x, myList(), i&, msg$, FileList
    FileList = Array("APPVD", "CCVB", "SSSSVB")
    myDir = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\ABSI"
    x = SearchFiles(myDir, "* *.*", 0, myList, myDir, FileList)
    If IsEmpty(x) Then MsgBox "No file found": Exit Sub
    For i = 1 To UBound(x, 2)
        If myList(1, i) <> myList(2, i) Then
            If Not IsFileOpen(x(1, i)) Then
                Call CheckFolder(x(2, i))
                Name x(1, i) As x(2, i)
            Else
                msg = msg & vbLf & x(1, i)
            End If
        End If
    Next
    If Len(msg) Then MsgBox "Follwing file(s) is/are currently in use", vbInformation, "Try later"
End Sub


Function SearchFiles(fPath$, myFileName$, n&, myList(), myDir, FileList) As Variant
    Dim e, fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.GetFolder(fPath).Files
        If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
        * (myFile.Name Like myFileName) Then
            If IsNumeric(Application.Match(Split(fso.GetBaseName(myFile.Name))(0), FileList, 0)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myFile.Path
                myList(2, n) = Join(Array(myDir, "YEAR_" & Year(myFile.DateLastModified), _
                    Split(fso.GetBaseName(myFile.Name))(0), "EXTRACTION_" & _
                    Choose(Month(myFile.DateLastModified), _
                    "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", _
                    "DEC"), myFile.Name), "\")
            End If
        End If
    Next
    For Each myFolder In fso.GetFolder(fPath).SubFolders
        SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList, myDir, FileList)
    Next
    SearchFiles = myList
End Function

---

works greatly !
much appreciated for your time & help jindon.:clap2: