delete folders on search

[Phoenix23]

Hi all thanks for helping me out with my initial problem on the folder move macro. I have managed to get it working by using a split function with alot of help from a friend in VBA and has the files searched and then moved if in wrong location. one massive thing I misjudged was duplications of the same named folder in each parent folder being searched - E.G New Folder , New Folder 2 etc. how would I go about deleting these files in my current code and still have the others puled across ? if anybody can help this would be great and save me about 4 hours of my day going through 500+ parent folders to just manually delete the unused folders. see code below

Sub moveFolders()    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim objFolder2 As Object
    Dim strDirectory As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long
    Dim objFileSystem As Object
    Dim x As Object, XNC As Object
    Dim Y As Integer
    
    
    baseDirectory = "C:\Users\Adam\Desktop\test\"
    archiveDirectory = baseDirectory & "Archive\"
    
    
    strDirectory = baseDirectory
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
    
    For Each objFolder In objFolders
    
        strDirectory2 = strDirectory + objFolder.Name
        Set objFSO2 = CreateObject("Scripting.FileSystemObject")
        Set objFolders2 = objFSO.GetFolder(strDirectory2).SubFolders
        
        parentValues = Split(objFolder, " - ")
        val1_0 = Split(parentValues(0), "\")
        If Not (IsNumeric(val1_0(UBound(val1_0)))) Then
            GoTo 1
        End If
        val1 = CLng(val1_0(UBound(val1_0)))
        val2 = CLng(parentValues(1))
        For Each objFolder2 In objFolders2
            childIs = objFolder2.Name
            Sheets("ARCHIVE").Range("A1000000").End(xlUp).Offset(1) = childIs
            If childIs < CLng(val1) Or childIs > CLng(val2) Then
                sourceIs = objFolder & "\" & childIs
                Set objFileSystem = CreateObject("Scripting.FileSystemObject")
                objFileSystem.MoveFolder Source:=sourceIs, Destination:=archiveDirectory
                
                
            End If
        Next
1
    Next objFolder
    MsgBox ("Done")
End Sub

[Sebastian H]

The best solution depends on what exactly you mean by “duplication”.

If you need to compare whether the content of directories is the same, then I'd recommend an external tool like WinMerge or SearchMyFiles.

If by “duplication” you mean that the names are in some way similar, then the easiest solution might be around an Excel table, in which you would express the condition of “duplication” with a formula for each folder name that results in a suggestion whether that folder should be deleted. Then you can sort and visually compare those directory names, and override the suggestion as needed.

To be more concrete: For the formula, it often can be useful to apply a regular expression – see https://strugglingtoexcel.com/2013/1...ssions-in-vba/. If, as one might infer from your example, duplications just differ from the original by an appended space and number, then you can easily get the original name with the formula

=RegExpReplace(RC[-1]," \d*$", "")

. In the next column, you can then search with MATCH() whether that name exists in any previous row, and if so, write something like “move” in the cell. Then you can have your macro read that value and handle each row accordingly.

[SamT]

First step is to delete all folders of Size 0
Recursion is your friend

Declare objFSO at module level, so the same FSO can be used by all recursions. Set obFSO in the main sub. In the main sub, call the Function described below, passing the root Folder

Build a Function that will take one Folder, IF it's size is 0 then
Delete it
exit Function.
Declare all needed Variables, Except obFSO, inside the function.
Else create a list of sub folders,
for each subfolder, call itself, passing the subfolder
Next SubFolder
End IF
End Function

That is a nice simple recursive function that should run thru 500 subfolders in 1 or 2 minutes while being a good example of recursiveness,

As for moving files: At first thought, I would use a Module level Dictionary to keep a list of files that are where they should be, A recursive function can use an outside non recursive function to manipulate the Dictionary for each File. The Dictionary can keep the LastModifiedDate as an Item so you can keep the latest file.Actually, I would use 2 outside functions, 1 to check the dictionary (Delete file if True) and 1 to update it (Continue if True). Both should return Booleans

[Sebastian H]

Interesting, SamT, that your approach is so different from mine. In some cases I can see where you're coming from, e.g. returning Booleans is better professional style, and it should give better performance. And removing empty folders first is certainly a nice example for a recursive function that has the didactic advantage to serve as a model for how to do deletion by any other conditions.

But about the dictionary, why would you not use the convenience of a spreadsheet, when you're already working with Excel?

[snb]

Your concept of archiving hasn't developed beyond filing paper.
Digital archiving is different.
Instead of many folders, subfolders you have to devise a systematic scheme how to address files in an unequivocal way. You can give them unique properties (ID) (e.g. in the name, like you would have done in foldernames). A file has many Windows properties nowadays, which can be shown in the explorer.
If you use this scheme systematically you can store all files in 1 'archive' directory and find each one by its unique ID / property, or a combination of properties.

[SamT]

IIRC, your folders are named by Case Number and the Files by Case Number and Document name. While snb is correct, I believe that your system makes more sense for a legal office

about the dictionary, why would you not use the convenience of a spreadsheet, when you're already working with Excel?

Working with ~500 folders and ~500(X) Files is going to take significant time. A Dictionary is just soooooooo much faster than a Spreadsheet. Besides, the FileName already has the folder location built in. All you really need to know is: "Is this the latest file properly stored?" I realize you must also, for legal reasons, archive every document ever created, Thus I would place an Archives folder in each Case folder, since if you ever need the archives, it will be on a Case by Case issue.

In fact, that operation is so Time consuming that Time becomes of the essence, therefore I would place the Dictionary and the two functions that access it in a Class Module, since CMs run in their own Thread. Save the Dictionary to Excel when Terminating the Class.

As to Archiving files with the same name, I have set the following as a permanent sub for Excel

Private Sub Workbook_BeforeSave(''')
    Me.SaveCopyAs ("D:\!Backup\_Personal\Personal - " & CStr(CDbl(Now)) & ".xls")
End Sub

Where CStr(CDbl(Now)) is just a unique, (to the millisecond,) ID.
Neither Windows nor Unix cares if the ID is before or after the file Extension

[Sebastian H]

A Dictionary is just soooooooo much faster than a Spreadsheet.

Thank you, that answers my question. You're right about that, of course. It seems the difference between our approaches is that you're focusing on perfecting the macro, while I want to make the transition from the current manual work process as easy as possible.

[snb]

Dim fs, c01

Sub M_snb()
  c00 = "G:\OF"
  Set fs = CreateObject("scripting.filesystemobject")
   
  M_snbrec c00
   
  MsgBox Join(Filter(Split(c01, vbLf), vbTab & "0"), vbLf), , "Empty Subfolders"
End Sub

Sub M_snbrec(c00)
  For Each it In fs.getfolder(c00).subFolders
    c01 = c01 & vbLf & it & vbTab & it.Size
    M_snbrec it
  Next
End Sub

NB. Adapt the starting directory "G:\OF"

[SamT]

There you go. Run snb's code, save the MsgBox contents to a sheet and have a list of all empty folders.
I think... snb's code approaches Arthur C. Clarke's definition of magic
NB. Do not use Option Explicit with any of snb's code

[Paul_Hossler]

Here's a (much) wordy-er version that uses the FSO to delete empty folders directly

Option Explicit


Const cTop As String = "D:\Testing"


Sub DeleteEmptyFolders()
    Dim oFSO As Object, oFolder As Object


    'create File System Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")


    Set oFolder = oFSO.GetFolder(cTop)


    Call CheckFolder(oFolder)
End Sub




Private Sub CheckFolder(o As Object)
    Dim oSubFolder As Object
    
'    Debug.Print "Checking " & o.Path
    For Each oSubFolder In o.SubFolders
        If oSubFolder.Size = 0 Then
'            Debug.Print "Deleting " & oSubFolder.Path
            oSubFolder.Delete
        Else
            Call CheckFolder(oSubFolder)
        End If
    Next
End Sub

[SamT]

Phoenix,

It's been 3 weeks since we last heard from you. Are you still there? Is your problem solved?

What's going on?