Sunday, May 27, 2007

VBA Dir Function to Get Sub Directories

Get Sub Directories using VBA Dir Function

The below function is used to get the immediate sub-directories for a given directory. If you want to dig deep into the directory structure then you need to iterate the sub-directories as well

Sub Get_All_SubDirectories()

Dim arSubDir() As String
Dim sSubDir As String

sSubDir = GetSubDir("d:\trash\")

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------

If LenB(sSubDir) <> 0 Then
arSubDir = Split(sSubDir, ";")
For i1 = 0 To UBound(arSubDir)
Debug.Print arSubDir(i1)
Next i1
End If

End Sub


Function GetSubDir(ByVal sPath As String, Optional ByVal sPattern As Variant) As Variant

Dim sDir As String
Dim sDirLocationForText As String

On Error GoTo Err_Clk

If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

If IsMissing(sPattern) Then
sDir = Dir$(sPath, vbDirectory)
Else
sDir = Dir$(sPath & sPattern, vbDirectory)
End If
' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------

Do Until LenB(sDir) = 0

' -----------------------------------------------------
' This will be the location for the sub directory
' -----------------------------------------------------
If sDir <> "." And sDir <> ".." Then
sDirLocationForText = sDirLocationForText & ";" & sPath & sDir
End If
sDir = Dir$

Loop

If Left$(sDirLocationForText, 1) = ";" Then sDirLocationForText = Right(sDirLocationForText, Len(sDirLocationForText) - 1)
GetSubDir = sDirLocationForText

Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Function

8 comments:

  1. Please post code for updated method - recursive deep searching in directory until lowest level.

    ReplyDelete
  2. Hi Anton

    Can you please check if this post (http://vbadud.blogspot.com/2010/05/how-to-iterate-through-all.html) helps you

    Thanks

    ReplyDelete
  3. this is not good idea. there may be many situation in which is windows installed on another partition, not C. simply modify of code will be enough.

    ReplyDelete
  4. Anonymous7:44 AM

    Hi My name is Hussain(patanwalahussain@gmail.com).
    i dont know any programming language.
    I want similar codes like this.

    requirements
    1) It should work with excel 2007.
    2) It should only list names with file extensions like ".pdf"
    3)It should ask me location before actual macro runs.
    4) It should also list all the file in desired path and also it should list all files in its sub directories
    for e.g. desired location
    \\calcrm\crmpdfs\ifc\2010\201008
    sub-directories
    batch0091
    batch0092 and so on.

    thanks in advance and request to send excel file without password protected to my email id patanwalahussain@gmail.com

    ReplyDelete
  5. Anonymous3:59 AM

    Sub ShowFolderList()
    Dim fs, f, f1, fc, s, fr, r, D, WSN
    Dim folderspec
    Dim I As Integer

    'Delete all the worksheets
    Workbooks.Add
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For I = ActiveWorkbook.Worksheets.Count To 1 Step -1
    If Worksheets(I).Name <> "Sheet1" Then Worksheets(I).Delete
    Next I

    'Insert worksheet with folder name
    folderspec = "D:\Dinakaran" 'CurDir()
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.SubFolders
    For Each f1 In fc
    With ActiveWorkbook.Sheets.Add
    ActiveSheet.Name = f1.Name
    End With
    Next

    'Delete Sheet1
    ActiveWorkbook.Sheets("Sheet1").Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    'List all the files
    For Each xlSheet In ActiveWorkbook.Worksheets
    WSN = xlSheet.Name
    D = "D:\Dinakaran\" & WSN & "\"
    xlSheet.Cells(1, 1) = "Filenames"
    r = 2
    fr = Dir(D, 7)
    Do While fr <> ""
    xlSheet.Cells(r, 1) = fr
    r = r + 1
    fr = Dir
    Loop
    'r = 0
    Next xlSheet
    End Sub

    ReplyDelete
  6. Anonymous1:49 AM

    It's perfect Anonymous.
    But if we have:
    D:\Lucru
    D:\Lucru\*.*
    D:\Lucru\2010
    D:\Lucru\2010\*.*
    D:\Lucru\2010\12032011
    D:\Lucru\2010\12032011\*.*
    D:\Lucru\2010\12032012
    D:\Lucru\2010\12032011\*.*

    Thanks

    ReplyDelete
  7. For this scenario is it possible to go even deeper and search content?

    ReplyDelete
  8. Anonymous2:16 PM

    With the same method can I search even deeper for specific content?

    ReplyDelete

StumbleUpon
Share on Facebook
Related Posts Plugin for WordPress, Blogger...
Download Windows Live Toolbar and personalize your Web experience! Add custom buttons to get the information you care about most.