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