Sub FindSubFolders()
On Error GoTo ErrorHandler
Dim fso As New FileSystemObject
Dim flds As Folders
Dim Response
Dim sFolders
Set flds = fso.GetFolder("C:\").SubFolders
For Each f In flds
sFolders = f.SubFolders.Count
Response = MsgBox(f.Path & " - Subfolders: " _
& sFolders, vbOKCancel, "Find Sub Folders")
If Response = vbCancel Then Exit For
Next
Exit Sub
ErrorHandler:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & vbLf & Err.Description
End If
On Error GoTo 0
End Sub