The below mentioned code successfully organizes the files in folders and then in subfolders format wise automatically. However, i just need one help that is if a file already exists in a subfolder and the same file was added again, it should kill the previously saved file and add the newly update file. Currently it gives error as "File Already Exist" however I really would like to request if please anyone can amend the code.
I have tried and searched on internet but unsuccessful. Please find the code below
Sub OrganizeFilesByFileType()
Const iFolderPath As String = "G:\!Archive Management\2023" ' adjust!!!
Dim FolderPath As String: FolderPath = "G:\!Archive Management\2023\"
If Len(FolderPath) = 0 Then Exit Sub
Dim FolderPaths As Collection
Set FolderPaths = CollSubfolderPaths(FolderPath)
MoveFilesToTypeFolders FolderPaths
End Sub
Function PickFolder( _
Optional ByVal InitialFolderPath As String = "", _
Optional ByVal DialogTitle As String = "Browse", _
Optional ByVal DialogButtonName As String = "OK", _
Optional ByVal ShowCancelMessage As Boolean = True) _
As String
Dim FolderPath As String, IsFolderPicked As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = DialogTitle
.ButtonName = DialogButtonName
Dim pSep As String: pSep = Application.PathSeparator
If Len(InitialFolderPath) > 0 Then
FolderPath = InitialFolderPath
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
.InitialFileName = FolderPath
End If
If .Show Then
FolderPath = .SelectedItems(1)
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
IsFolderPicked = True
End If
End With
If IsFolderPicked Then PickFolder = FolderPath: Exit Function
If ShowCancelMessage Then
MsgBox "Dialog canceled.", vbExclamation, "Pick Folder"
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the paths of a folder ('FolderPath')
' and all of its subfolders in a collection.
' Remarks: Check it only against 'Nothing' (its count cannot be 0).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollSubfolderPaths( _
ByVal FolderPath As String, _
Optional ByVal IncludeFolderPath As Boolean = True) _
As Collection
Const ProcName As String = "CollSubFolderPaths"
On Error GoTo ClearError
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(FolderPath) Then Exit Function
Dim collPaths As Collection: Set collPaths = New Collection
Dim collQueue As Collection: Set collQueue = New Collection
collQueue.Add FSO.GetFolder(FolderPath)
Dim fsoFolder As Object
Dim fsoSubfolder As Object
Do Until collQueue.Count = 0
Set fsoFolder = collQueue(1)
collQueue.Remove 1 ' dequeue!
collPaths.Add fsoFolder.Path
For Each fsoSubfolder In fsoFolder.SubFolders
collQueue.Add fsoSubfolder ' enqueue!
Next fsoSubfolder
Loop
If Not IncludeFolderPath Then
If collPaths.Count = 1 Then Exit Function
collPaths.Remove 1
End If
Set CollSubfolderPaths = collPaths
ProcExit:
Exit Function
ClearError:
Debug.Print "@" & ProcName & "@ Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
Sub MoveFilesToTypeFolders( _
ByVal FolderPaths As Collection, _
Optional ByVal ShowMessage As Boolean = True)
Const PROC_TITLE As String = "Move Files To Type Folders"
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
' Keys: Type Folder Paths (New), Items: True or False i.e. exists or not
Dim foDict As Object: Set foDict = CreateObject("Scripting.Dictionary")
foDict.CompareMode = vbTextCompare
' Keys: File Paths (Old), Items: Type File Paths (New)
Dim fiDict As Object: Set fiDict = CreateObject("Scripting.Dictionary")
fiDict.CompareMode = vbTextCompare
Dim Item, fsoFolder As Object, fsoFile As Object
Dim FolderName As String, FileType As String, TypePath As String
For Each Item In FolderPaths
Set fsoFolder = FSO.GetFolder(Item)
FolderName = fsoFolder.Name
For Each fsoFile In fsoFolder.Files
FileType = fsoFile.Type
If StrComp(FolderName, FileType, vbTextCompare) <> 0 Then
TypePath = FSO.BuildPath(Item, FileType)
If Not foDict.Exists(TypePath) Then
foDict(TypePath) = FSO.FolderExists(TypePath)
End If
fiDict(fsoFile.Path) = FSO.BuildPath(TypePath, fsoFile.Name)
'Else ' the file is already in its type folder; do nothing
End If
Next fsoFile
Next Item
' Create the folders.
For Each Item In foDict.Keys
If Not foDict(Item) Then FSO.CreateFolder Item
Next Item
' Move the files.
For Each Item In fiDict.Keys
Debug.Print Item, fiDict(Item)
FSO.MoveFile Item, fiDict(Item)
Next Item
If ShowMessage Then
If fiDict.Count > 0 Then
Else
End If
End If
End Sub
Sub OrganizeFilesByFileType()
If Len(FolderPath) = 0 Then Exit Sub
Set FolderPaths = CollSubfolderPaths(FolderPath)
End Sub
Function PickFolder( _
Optional ByVal InitialFolderPath As String = "", _
As String
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Purpose: Returns the paths of a folder ('FolderPath') ' and all of its subfolders in a collection. ' Remarks: Check it only against 'Nothing' (its count cannot be 0). ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollSubfolderPaths( _
ByVal FolderPath As String, _
Optional ByVal IncludeFolderPath As Boolean = True) _
As Collection
Const ProcName As String = "CollSubFolderPaths"
On Error GoTo ClearError
ProcExit:
ClearError:
Debug.Print "@" & ProcName & "@ Run-time error '" _
Resume ProcExit
End Function
Sub MoveFilesToTypeFolders( _
Const PROC_TITLE As String = "Move Files To Type Folders"
End Sub