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