Excel 2007 - VBA macro to List all sub-folders that contains folder name as Numeric

[chamdan]

Hi,

Can someone help write a macro that will list in column 1 all the sub-folders that have a name that start with 4500 or 4600. e.g. if a folder starts with 4600 you may have sub-folders that have a name that starts with 4500 and if the found folder name starts with 4500 then list it in column A and look for the next folder at the same level.

example:

C:\sample1
C:\Sample1\4600xxxx
C:\Sample1\4600xxxx\4500xxxx
C:\Sample1\4600xxxx\4500xxxx
C:\Sample1\4600xxxx\4500xxxx
C:\Sample2
C:\Sample2\4500xxxx
C:|Sample2\4500xxxx

So the objective is to list all those folders that have as either 4600xxxx or 4500xxxx

I look forward to your help.

Regards,

Chuck

[snb]

What VBA did you write yourself ?

[chamdan]

Hi Snb

I got this macro from one of the forum, I can't remember which one but it lists all the Folders and Sub-folders in column 1 but my objective is to select only the ones as listed in my prior question and list in column 1 only the part which name is 4600xxxx or 4500xxxx where xxxx can change in column 1 (A) I want to show the 4600xxxx and in column 2 (B) the 4500xxx. I could not figure out how to do that I am a newbie in vba.

This is how it should look like:

4600xxxx
4500xxxx
4500xxx2
4500xxx3

here below is the macro I got from one forum:

'Looping Through Folders and Files in VBA
Public ObjFolder As Object

Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public  objFl As Object
   

'===================================================================
'A procedure to call the Function  LoopThroughEachFolder(objFolder)
'===================================================================
   
Sub GetFolderStructure()
'
    lngCounter = 0
    Set objFso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        Set ObjFolder = objFso.GetFolder(.SelectedItems(1))
    End With
    Range("A1").Offset(lngCounter).Value = ObjFolder.Path
    LoopThroughEachFolder ObjFolder
   
End Sub
'=================================================== 
'Function to Loop through each Sub Folders
'=================================================== 

Function LoopThroughEachFolder(fldFolder As Object)

    For Each objFldLoop In fldFolder.subFolders
    lngCounter = lngCounter + 1
    Range("A1").Offset(lngCounter).Value = objFldLoop.Path
    LoopThroughEachFolder objFldLoop
    Next

End Function

[chamdan]

I finally made to work but still need few tune up to look as I wish. Here is the macro:

'Looping Through Folders and Files in VBA
Public ObjFolder As Object

Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
   

'===================================================================
'A procedure to call the Function  LoopThroughEachFolder(objFolder)
'===================================================================
   
Sub GetFolderStructure()
'
    lngCounter = 0
    Set objFso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        Set ObjFolder = objFso.GetFolder(.SelectedItems(1))
    End With
    Range("A1").Offset(lngCounter).Value = ObjFolder.Path
    LoopThroughEachFolder ObjFolder
   
End Sub
'===================================================
'Function to Loop through each Sub Folders
'===================================================

Function LoopThroughEachFolder(fldFolder As Object)
Dim P As Long

    For Each objFldLoop In fldFolder.subFolders
    lngCounter = lngCounter + 1
    P = InStr(1, objFldLoop.Path, "4600")
    If P <> 0 Then
           Range("A1").Offset(lngCounter).Value = Mid(objFldLoop.Path, P, 10)
    Else
        P = InStr(1, objFldLoop.Path, "4500")
        If P <> 0 Then
           Range("A1").Offset(lngCounter).Value = Mid(objFldLoop.Path, P, 10)
        End If
    End If
        LoopThroughEachFolder objFldLoop
    Next

End Function

Hope this will help others too.

Cheers!

Chuck