SubFolders of GetFolder(x).SubFolders

[rrenis]

Hi - can anyone help me out please? I've learnt VBA from reading boards and searching google so the following is probably not best practice! :o:

I have the following code which works fine when looping through the first set of subfolders for myLocationDest but as soon as it goes to search the subfolders of myLocationSub1 (the returned subfolder of myLocationDest) it doesn't return the correct folders that match the reference :banghead:

The reason for this code is to automatically file files in the temp directory into SubFolders which match the references contained within the SubFolders. An example of this is...

Ref 1234.0102 report.xls would be filed as...

C:\Projects\1234 My Project\01 Reports\02 Excel Reports\

I have 3 GetFolder searches to try and acheive this...

1 to find the \1234 My Project\ subfolder (from 1234.0102)
1 to find the \01 Reports subfolder (from 1234.0102)
1 to find the \02 Excel Reports\ subfolder (from 1234.0102)


On Error Resume Next
Dim myName As String
Dim myLocationTemp As String
Dim myLocationDest As String
Dim myLocationSub1 As String
Dim myLocationSub2 As String
Dim FSO As Object
Dim FolderSubFolder As Object
Dim FolderSubFolderSub1 As Folder
Dim FolderSubFolderSub2 As Folder
Dim TempString As String
Dim TempString2 As String
Dim lCount As Long
Dim myFullFilename As String
Dim myFilename As String
Dim myRef As String
Dim myRefSub1 As String
Dim myRefSub2 As String
Dim myRefSubCheck As String
myLocationTemp = "C:\Projects\Temp\"
myLocationDest = "C:\Projects\"
Set FSO = CreateObject("Scripting.FileSystemObject")

With Application.FileSearch
.NewSearch
.LookIn = myLocationTemp
.FileType = msoFileTypeAllFiles

If .Execute > 0 Then
For lCount = 1 To .FoundFiles.Count
myFullFilename = .FoundFiles(lCount)
myFilename = Mid(.FoundFiles(lCount), InStr(.FoundFiles(lCount), "Temp\") + 5, 256)
myRef = Mid(.FoundFiles(lCount), InStr(.FoundFiles(lCount), "Ref ") + 4, 4)
myRefSubCheck = Mid(.FoundFiles(lCount), InStr(.FoundFiles(lCount), "Ref ") + 9, 4) ' eg 1234-0102
myRefSub1 = Mid(.FoundFiles(lCount), InStr(.FoundFiles(lCount), "Ref ") + 9, 2) ' eg 01
myRefSub2 = Mid(.FoundFiles(lCount), InStr(.FoundFiles(lCount), "Ref ") + 11, 2) ' eg 02

For Each FolderSubFolder In FSO.GetFolder(myLocationDest).SubFolders
TempString = FolderSubFolder.Name
myLocationSub1 = TempString
If myFullFilename = "" Then GoTo NextFile Else
If Left(TempString, InStr(TempString, myRef)) = True Then GoTo Sub1 Else

Next FolderSubFolder
Sub1:
For Each FolderSubFolderSub1 In FSO.GetFolder(myLocationDest & myLocationSub1 & "\").SubFolders
TempStringSub1 = FolderSubFolderSub1.Name
myLocationSub2 = TempStringSub1
If Left(TempStringSub1, InStr(TempStringSub1, myRefSub1)) = True Then GoTo Sub2 Else
Next FolderSubFolderSub1
Sub2:
For Each FolderSubFolderSub2 In FSO.GetFolder(myLocationDest & myLocationSub1 _
& "\" & myLocationSub2 & "\").SubFolders
TempStringSub2 = FolderSubFolderSub2.Name
If Left(TempStringSub2, InStr(TempStringSub2, myRefSub2)) = True Then GoTo MoveFile Else
Next FolderSubFolderSub2
MoveFile:
If myRefSubCheck >= 101 Then Name myFullFilename As myLocationDest _
& TempString & "\" & TempStringSub1 & "\" & TempStringSub2 & "\" & myFilename Else
If myRefSubCheck >= 1 Then Name myFullFilename As myLocationDest _
& TempString & "\" & TempStringSub1 & "\" & myFilename Else
If myRefSubCheck < 1 Then Name myFullFilename As myLocationDest _
& TempString & "\" & myFilename
NextFile:
Next lCount
End If

End With


Edit Lucas: Line breaks added so the code doesn't run off the page for those with small monitors

Any help would be greatly appreciated : pray2:

Cheers,
rrenis

[lucas]

Here are a couple of links to kb entries dealing with subdirectories:
http://vbaexpress.com/kb/getarticle.php?kb_id=405
http://vbaexpress.com/kb/getarticle.php?kb_id=837
http://vbaexpress.com/kb/getarticle.php?kb_id=800
http://vbaexpress.com/kb/getarticle.php?kb_id=276
http://vbaexpress.com/kb/getarticle.php?kb_id=781
should give you some ideas. Post back with questions.

[rrenis]

thanks lucas - i'll have a look and let you know how I get on!

cheers,
rrenis

[rrenis]

Hi lucas - I take it my code is no good?... :mkay

Looking at the knowledge base - Do I need to be using recussive folders? If so I must admit I'm having trouble understanding how I can incorporate it :omg2:- like I said I've taught myself VBA and only have what I guess is a basic understanding.

cheers,
rrenis

[lucas]

Hi rrenis,
First of all I'm not sure exactly what your trying to do. If I understand your searching a directory and several subdirectories for multiple files....


Ref 1234.0102 report.xls would be filed as...


Does this mean the file above can be in several different directories?

[rrenis]

Hi lucas,

The file Ref 1234.0102 report.xls is in C:\Projects\Temp\ (a dump directory) along with many other files which have a similar structure in the filename i.e.

Ref 2345.0306 report.xls
Ref 1223.0101 letter.doc
etc, etc...

C:\Projects\ contains all of the project folders which contain a unique 4 figure numerical reference. In turn each project folder contains sub folders with 2 figure numerical references, i.e...

C:\Projects\1234 My Project\01 Reports\02 Excel Reports\

I'm not searching the project directories for files - just the folder names so the code can find a match for the file/s in the C:\Project\Temp directory (using inStr). The idea then being to push the code onto the MoveFiles: code to move the file in question to the correct project folder and subfolder.

My code does work if you delete the code contained within Sub1: and Sub2: but obviously that will only move...

Ref 1234.0102report.xls

to

C:\Projects\1234 My Project\

and not

C:\Projects\1234 My Project\01 Reports\02 Excel Reports\

which is what I need

Hope this makes more sense that the original post :o:

Cheers,
rrenis

[lucas]

I'm thinking that it would be much easier to save the files to a correct directory rather than use the dump in the first place. Looks like your trying to automate moving and reorganizing files in mult directories using vba?

[rrenis]

Hi lucas, I agree but unfortunately I'm stuck with the dump folder - it's not actually on the C drive its' on the server I just changed it to C in case anyone wanted to run the code to see what it's doing.

Any ideas on where I could go from here :dunno

[lucas]

Not really but there are others in the forum with better skills in this area. One question for them. Are you trying to copy the files or actually move them?

[rrenis]

Hi lucas - I just need to move them.

Thanks for helping out :thumb

Cheers,
rrenis

[lucas]

There are some really skilled coders on this board and a few of them are around this morning....be patient and I'm sure that help or advice will be coming your way soon.

[rrenis]

Thanks lucas - It would be great if someone could help to get this code working :bow:

Cheers,
rrenis

[Bob Phillips]

I am confused by what the end result looks like. I think I see a start position, but not the, and I am afraid I cannot work with your code, jumping out of For ... Next loops scares me.

Can you give a diagram of the start position, something like



C:\Projects
... \Temp
... Ref 1234.0102 report.xls
Ref 2345.0306 report.xls
Ref 1223.0101
... \1234 My Projects

etc.,

and what you would expect it to end like

[mdmackillop]

I'm not clear if you're working with different file types, as this code will not distinguish


Option Explicit
Sub MoveFiles()
Dim MyPath As String, MyFile As String
MyPath = "c:\Projects\Temp\" ' Set the path.
MyFile = Dir(MyPath) ' Retrieve the first entry.
Do While MyFile <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyFile <> "." And MyFile <> ".." Then
DoSave MyPath, MyFile
End If
MyFile = Dir ' Get next entry.
Loop
End Sub

Sub DoSave(MyPath As String, MyFile As String)
Dim Lev0 As String, Lev1 As String, Lev2 As String, Lev3 As String
Dim OldName As String, NewName As String
Lev0 = "C:\Projects\"
Lev1 = Split(MyFile, ".")(0) & " My Project\"
Lev2 = Left(Split(MyFile, ".")(1), 2) & " Reports\"
Lev3 = Mid(Split(MyFile, ".")(1), 3, 2) & " Excel Reports\"
OldName = MyPath & MyFile
NewName = Lev0 & Lev1 & Lev2 & Lev3 & MyFile
Name OldName As NewName
End Sub

[rrenis]

Hi xld - thanks for the reply!
:beerchug:
I hope this is what you want...

Start Position

The C:\Projects\Temp\ folder will have numerous files in which could look like this...

(A) C:\Projects\Temp\1234.0101 report.xls
(B) C:\Projects\Temp\2434.0201 hello.doc
(C) C:\Projects\Temp\1224.0101 report.xls
(D) C:\Projects\Temp\1234.0102 report.doc

etc...

The End Result

(A) would be moved to...

C:\Projects\1234 My Project\01 Reports\01 Excel Reports\

(B) would be moved to...

C:\Projects\2434 Another Project\02 Letters\01 Correspondence\

(C) would be moved to...

C:\Projects\1224 Yet Another Project\01 Reports\01 Excel Reports\

(D) would be moved to...

C:\Projects\1224 Yet Another Project\01 Reports\02 Word Reports\


Hope this helps : pray2:

Cheers,
rrenis

[mdmackillop]

Just spotted the Ref in the file name. A small adjustment needed.
Can you confirm that all of the file names are exactly the same format?

[rrenis]

Hi mdmackillop - thanks for the reply - I'll give it a go.
:beerchug:
I'll be looking to move .xls, .doc. .txt and .msg files. I used msoFileTypeAllFiles in my code as a catch all - not sure if I can apply it here?

Is there any way of making the reference to '\Reports' and '\Excel Reports' viariable in the code? The reason I ask is that there are many sub folders in the standard filing subfolder structure that I'm filing into.

Cheers,
rrenis

[Bob Phillips]

How about this? I couldn't get it quite as you said, How do I know when to use Correspondence etc.?



Public Sub MoveFiles()
Const sLocationTemp = "C:\Projects\Temp\"
Const sLocationDest = "C:\Projects\"
Dim oFSO As Object
Dim sFile As String
Dim sFileNum As String
Dim sFileSub1 As String
Dim sFileSub2 As String
Dim sFileType As String
Dim sDir As String

sFile = Dir(sLocationTemp & "\" & "*.*")
Do While sFile <> ""
sFileNum = Mid(sFile, 5, 4)
sFileSub1 = Mid(sFile, 10, 2)
sFileSub2 = Mid(sFile, 12, 2)
sFileType = Mid(sFile, 15, Len(sFile) - 15 - 4 + 1)
sDir = sLocationDest & sFileNum & " My Project" & "\" & _
sFileSub1 & " " & sFileType & "s\"
If Right(sFile, 3) = "xls" Then
sDir = sDir & sFileSub2 & " Excel " & sFileType & "s"
Else
sDir = sDir & sFileSub2 & " Word " & sFileType & "s"
End If
Call MakeDirectories(sDir)
Name sLocationTemp & "\" & sFile As sDir & "\" & sFile
sFile = Dir
Loop
End Sub

Private Sub MakeDirectories(ByVal StartDir As String)
Dim iPos As Long
Dim sDir As String

iPos = InStr(1, StartDir, ":") + 1
Do
iPos = InStr(iPos + 1, StartDir, "\")
If iPos > 0 Then
sDir = Left(StartDir, iPos - 1)
On Error Resume Next
MkDir sDir
On Error GoTo 0
End If
Loop Until iPos = 0
On Error Resume Next
MkDir StartDir
On Error GoTo 0

End Sub

[rrenis]

Hi mdmackillop - the file names are in the same format - i.e. a 4 figure reference followed by . followed by two 2 figure references for each of the subfolders.

Cheers,
rrenis

[rrenis]

Hi xld - thank you for the code. I'll have to try it tomorrow unfortunately as I'm about to leave the office - I'll let you know how it goes.

With regard to when to use Correspondence this would be picked up by the 01 reference. In this case for example in the 02 subfolder 01 would be Correspondence. The references to 'Correspondence' and 'Reports' in the ubFolder names are purely examples. Any code would need to search on the numerical references unfortunately :(

I employed inStr in my code to search out the numerical references but once I got past the 1234 My Project\ folder for example it didn't pick up the correct folders from the 2 figure numerical references :(

Cheers,
rrenis

[rrenis]

Just a quick note the file references could look like this and all the different variables that includes...

1234.1012 report.xls - i.e. 10 sub folders of \1234 and 12 subfolder of \10

Cheers,
rrenis

[mdmackillop]

This assumes all the folders exist.

Option Explicit

Sub MoveFiles()
Dim MyPath As String, MyFile As String
MyPath = "c:\Projects\Temp\" ' Set the path.
MyFile = Dir(MyPath) ' Retrieve the first entry.
Do While MyFile <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyFile <> "." And MyFile <> ".." Then
DoSave MyPath, MyFile
End If
MyFile = Dir ' Get next entry.
Loop
End Sub

Sub DoSave(MyPath As String, MyFile As String)
Dim Lev0 As String, Lev1 As String, Lev2 As String, Lev3 As String
Dim Fld As String
Dim OldName As String, NewName As String

Lev0 = "C:\Projects\"

Lev1 = Split(MyFile, ".")(0)
Fld = Lev0 & FName(Lev0, Lev1) & "\"

Lev2 = Left(Split(MyFile, ".")(1), 2)
Fld = Fld & FName(Fld, Lev2) & "\"

Lev3 = Mid(Split(MyFile, ".")(1), 3, 2)
Fld = Fld & FName(Fld, Lev3) & "\"

OldName = MyPath & MyFile
NewName = Fld & MyFile

Name OldName As NewName
End Sub

Function FName(folderspec, Num As String)
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set sf = f.SubFolders
For Each f1 In sf
If Left(f1.Name, Len(Num)) = Num Then
FName = f1.Name
Exit For
End If
Next
End Function

[Bob Phillips]

I think I catered for all of that. ALl I didn't cater for is file extensions other than xls and doc

[rrenis]

Hi xld and mdmackillop :hi:

Thank you both so much for giving up your time to help me with this. :bow:

I ended up using the code mdmackillop supplied as it already included for moving all types files. I've just tested it and it works great!!:clap:

I thought I was roughly on the right track with my original code too!:rotlaugh:

Just one more thing... :o:

Some of the files will have 'Ref' or if it's a .msg file the sender's name in front of the initial 4 figure numerical reference (1234). I've noticed that these files are not filed correctly. Would it be possible to cater for these files within the code? If not I look at a macro to remove everything to the left of the initial 4 figure numerical reference (1234). In the mean time I'll see if I can figure this out myself.

Once again, thank you both for helping!
:beerchug:
Cheers,
rrenis

[mdmackillop]

No time to code it just now, but you could look at splitting the filename with space as a delimiter, test for the ubound figure, 0 or 1, and use the appropriate part.

[rrenis]

Thanks mdmackillop, I'll have look on google to see what you mean and give it a go!!

Your code is going to make my life much easier - thanks again!!

Cheers,
rrenis

[rrenis]

hi - mdmackillop - I'm not really getting anywhere with what you suggested which is really down to me not having a wide knowledge of VBA I guess. I think I'm going to try coming up with something that using inStr to find the four figure reference and then rename each file to strip out the text before the reference.

Cheers,
rrenis

[mdmackillop]

Modify DoSave as follows
Lev0 = "C:\Projects\"

If UBound(Split(MyFile, " ")) = 2 Then
MyFile = Split(MyFile, " ")(1) & " " & Split(MyFile, " ")(2)
End If

[rrenis]

:bow: :bow: :bow:

Thanks mdmackillop!!

Have just been trying to work out the code I spoke about in my last post! Thanks for posting back the solution it's much better than what I had in mind :doh:

Thanks again!

Cheers,
rrenis

[rrenis]

Hi mdmackillop - I've changed the DoSave to the following

but after some messing around the only way it will file correctly is if I change the format of the Reference from

4441.0101 to 4441..01.01

If UBound(Split(MyFile, " ")) = 2 Then
MyFile = Split(MyFile, " ")(1) & " " & Split(MyFile, " ")(2)
End If

Lev1 = Split(MyFile, ".")(0)
Fld = Lev0 & FName(Lev0, Lev1) & "\"

Lev2 = Left(Split(MyFile, ".")(1), 2)
Fld = Fld & FName(Fld, Lev2) & "\"

Lev3 = Mid(Split(MyFile, ".")(1), 3, 2)
Fld = Fld & FName(Fld, Lev3) & "\"



The files which are causing the problem in this particular case are .msg files which look like this...

Bloogs, Joe (ABC) - Ref 1234.0101 Subject line text (02.02.2007-10.10.10) [12.00].msg

Sorry about this but any Ideas what's happening? :confused2

Cheers,
rrenis.