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
Code: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