Movian
09-26-2011, 12:06 PM
Ok,
i have a situation where there are two sets of folders, one old one new (about 6,000 of each) i need to write up a macro to move the contents of the old folders (sub folders and files) to the new folders.
However the fso.Movefolder option doesn't have a merge option like windows does when you move a folder with the same name together. and short of writing up a recursive sub to search the sub folders etc i figured there had to be an existing quicker solution.
I have the current macro setup, need to do this asap. Any help is appreciated.
Just to note the folder structure is lastname, firstname(ID)
with the new folders ID numbers being exactly 9000 higher than the old folders id numbers. Also the old ID's are 4 digits long (starting at 1000) so the coding dealing with those items is to seperate the two lists of folders.
Dim DirectoryName, fixname As Variant
Dim sql, fso As New FileSystemObject
Dim Folder As String
Folder = "D:\folderlocations\"
DirectoryName = Dir(Folder, vbDirectory)
Do Until DirectoryName = ""
If DirectoryName <> "." And DirectoryName <> ".." Then
If (GetAttr(Folder & DirectoryName) And vbDirectory) = vbDirectory Then
fixname = Split(DirectoryName, "(")
On Error Resume Next
If Len(fixname(1) - 1) = 4 Then
fso.MoveFolder Folder & DirectoryName, Folder & fixname(0) & "(" & CStr(CInt(left(fixname(1), Len(fixname(1)) - 1) + 9000)) & ")"
End If
On Error Resume Next
End If
End If
DirectoryName = Dir
Loop
i have a situation where there are two sets of folders, one old one new (about 6,000 of each) i need to write up a macro to move the contents of the old folders (sub folders and files) to the new folders.
However the fso.Movefolder option doesn't have a merge option like windows does when you move a folder with the same name together. and short of writing up a recursive sub to search the sub folders etc i figured there had to be an existing quicker solution.
I have the current macro setup, need to do this asap. Any help is appreciated.
Just to note the folder structure is lastname, firstname(ID)
with the new folders ID numbers being exactly 9000 higher than the old folders id numbers. Also the old ID's are 4 digits long (starting at 1000) so the coding dealing with those items is to seperate the two lists of folders.
Dim DirectoryName, fixname As Variant
Dim sql, fso As New FileSystemObject
Dim Folder As String
Folder = "D:\folderlocations\"
DirectoryName = Dir(Folder, vbDirectory)
Do Until DirectoryName = ""
If DirectoryName <> "." And DirectoryName <> ".." Then
If (GetAttr(Folder & DirectoryName) And vbDirectory) = vbDirectory Then
fixname = Split(DirectoryName, "(")
On Error Resume Next
If Len(fixname(1) - 1) = 4 Then
fso.MoveFolder Folder & DirectoryName, Folder & fixname(0) & "(" & CStr(CInt(left(fixname(1), Len(fixname(1)) - 1) + 9000)) & ")"
End If
On Error Resume Next
End If
End If
DirectoryName = Dir
Loop