On Dec 1, 6:18*am, Snoopy wrote:
Hey Guys
I hope you will help me again :)

I found this macro at Tom Ogilvys (thanks Tom).
It generates a name-list of the subfolders in the one mainfolder c:
\MyRoot\

My challenge is to make a analogous list of all the subfolders (only
the 4 caractres to the left in the subfoldername) in a selection of
mainfolders.
The selection of mainfolder is based on the beginng of foldername: "H:
\Order *\".

H:\order 2004\
H:\order 2005\
H:\order 2006\
H:\order 2007\
*and so on

The final list will go like this:
0104
0204
..
1504
0105
0205
0305
...
9905
and so on.

Sub ListSubs()
Dim MyPath As String, MyName As String
Dim rw As Long

rw = 1
MyPath = "c:\MyRoot\" ' Set the path.
MyName = Dir(MyPath, vbDirectory) ' Retrieve the first entry.
Do While MyName < "" ' Start the loop.
*' Ignore the current directory and the encompassing directory.
If MyName < "." And MyName < ".." Then
* ' Use bitwise comparison to make sure MyName is a directory.
* If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
* *Cells(rw, 1).Value = MyName ' Display entry only if it
* *rw = rw + 1 * * * * * * * ' *represents a directory.
* End If
*End If
*MyName = Dir ' Get next entry.
Loop
End Sub

Do anyone feel to guide me on this one?

Best Regards Snoopy

For some reason just passing the folder to a sub caused an error when
I returned to the calling sub.
So I wrote the folder names to column A and then read that column and
wrote subfolder names in Column B.
HTH
Tom


Dim rwP As Long
Sub ListFolders()
'modified to write folders to column A
Dim MyPath As String, MyName As String, FolderPrefix As String

Dim rw As Long

FolderPrefix = "Order"
rwP = 1
rw = 1
MyPath = "F:\" ' Set the path.
MyName = Dir(MyPath, vbDirectory) ' Retrieve the first entry.
Do While MyName < "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName < "." And MyName < ".." Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
If Mid(MyName, 1, 5) = FolderPrefix Then 'Look for folders of the
type wanted
Cells(rw, 1).Value = MyPath & MyName & "\"
rw = rw + 1
End If
End If
'
End If
MyName = Dir ' Get next entry.
Loop
ListSubs2
End Sub
Sub ListSubs2()
' Modified to read folders from column A and write subfolers to column
B
Dim MyPath As String, MyName As String
Dim MyName2 As String
Dim Myrow
Dim rw As Long
rwP = 1
If Cells(1, 1).CurrentRegion.Rows.Count = 1 Then
If (Cells(1, 1).Value) = "" Then
Exit Sub
End If
End If
For Each Myrow In Cells(1, 1).CurrentRegion.Rows
MyPath = Myrow.Cells(1, 1).Value
MyName2 = Dir(MyPath, vbDirectory) ' Retrieve the first entry.
Do While MyName2 < "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName2 < "." And MyName2 < ".." Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(MyPath & MyName2) And vbDirectory) = vbDirectory Then
Cells(rwP, 2).Value = MyName2 ' Display entry only if it
rwP = rwP + 1 ' represents a directory.
End If
End If
MyName2 = Dir ' Get next entry.
Loop
Next
End Sub