Move files based on specific words location in new folders

[Mussa]

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.

[June7]

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-loop-files-folder-sub-folders/

[Mussa]

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.

Have you made any attempt?
not yet , I'm still search for something close .

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

every file will contains modified date for properties .

Start with understanding code that loops through files.

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

[June7]

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.

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

[Aussiebear]

Maybe this will get you started?



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

[Mussa]

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.

[Mussa]

June7

shows me error invalid procedure call or argument in this line

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

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




should be

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

[Aussiebear]

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

[Mussa]

Maybe this will get you started?

How run your code?

[June7]

Don't know how that declaration got messed up in post. This is how it is in my 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.

[Paul_Hossler]

you can try this



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

[Mussa]

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

Name sOldName As sNewName

[Mussa]

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

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

[June7]

I wrote and tested code with Excel 2010.

GetAttr() Is an intrinsic function https://learn.microsoft.com/en-us/office/vba/Language/Reference/user-interface-help/getattr-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?

[Paul_Hossler]

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

Name sOldName As sNewName



Did you change this?



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


What does the Debug window say?



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

[jindon]

try


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

[Mussa]

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!

[Mussa]

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.

[jindon]

Then


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

[Mussa]

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

and ignore files names don't contain theses three words

otherwise ignore others files from moving.
so any file doesn't move within Year_2025 if doesn't contain words ("PPVD", "CCVB", "SSSSVB")

[jindon]

Replace "test" & "SearchFiles" procedures with below


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

[Mussa]

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