サブディレクトリのみの存在有無を確認する方法

たくさん有るフォルダのうち、一定の割合で更に中にフォルダが保存されており、「フォルダの中にフォルダが有る」フォルダを抽出したいのですが（ややこしくてすいません・・・。）

「Do while Dir(パス,vbDirectory)=""」などを利用した場合、内部のフォルダ名がわからなくては反応しませんし、パスをﾜｲﾙﾄﾞｶｰﾄﾞ付きの文字列に定義すると、フォルダでなくファイルにも反応してしまい、確認することができません。

ﾌｫﾙﾀﾞを内包しているﾌｫﾙﾀﾞのみ抽出する方法についてアドバイスいただけたら幸いです。
些細なヒントでも構いません。　よろしくお願いします。

(追記)
分かりずらい文章で申し訳ありません。
フォルダ名を抽出というよりは、ﾌｧｲﾙに反応せずに、フォルダの場合のみTrueとなるようなものが作成したく相談致しました。　（フォルダ名は統一性がありません）

ファイルのみが入っているﾌｫﾙﾀﾞ→×　
ﾌｫﾙﾀﾞのみ→〇
ﾌｫﾙﾀﾞとﾌｧｲﾙ→〇

全てのﾌｧｲﾙ、フォルダ名を抽出して最後に拡張子のあるものを削除するしかないでしょうか。
上記の方法より良い方法が在りましたらよろしくお願いします。

行動規範の内容に同意します

回答3件

こちらをご参考に
【VBA】フォルダ内のフォルダ一覧を取得する（サブフォルダ内を含む）

teratailの過去事例にも類似したものがあったと思います。

投稿2020/08/18 06:32

DreamTheater

総合スコア1095

ベストアンサー

全てのﾌｧｲﾙ、フォルダ名を抽出して最後に拡張子のあるものを削除するしかないでしょうか。

↑
この方法に近いですが、DOSコマンドのDirコマンドに/adオプションをつければフォルダ情報のみ
取り出すことができます。さらに/sオプションでサブフォルダも検索すれば指定フォルダ以下のすべての
フォルダ情報を得られます。

Dir xxxxx /ad /s
↓

C:\Users\hogehoge\AppData\Roaming\Microsoft のディレクトリ

020/03/13 09:47 <DIR> .
020/03/13 09:47 <DIR> ..
020/08/07 09:12 <DIR> Credentials
016/03/04 14:59 <DIR> Crypto
020/08/03 10:53 <DIR> Forms
020/03/06 15:33 <DIR> Protect
016/03/07 17:06 <DIR> SystemCertificates
0 個のファイル 0 バイト

C:\Users\h.horikoshi\AppData\Roaming\Microsoft\Credentials のディレクトリ

2020/08/07 09:12 <DIR> .
2020/08/07 09:12 <DIR> ..
0 個のファイル 0 バイト
:

あとはこれを解析すればいかがかと…

サンプルコード

Private Sub CommandButton1_Click()

  Dim root As String: root = "C:\Users"          ' ルートパス
  '
  ' Dirコマンドを発行して結果をtxtに格納
  '
  Dim wSh As Object: Set wSh = CreateObject("WScript.Shell")
  Dim wEx As Object: Set wEx = wSh.exec("%ComSpec% /c Dir """ & root & """ /ad /s")
  Dim txt As String: txt = wEx.StdOut.ReadAll
  Set wEx = Nothing
  Set wSh = Nothing
  '
  ' txtを1行ごとに分解。※フォルダ名はフルパスで入っている。
  '
  Dim lines As Variant
  lines = Split(txt, vbCrLf)
  '
  ' 1行ごと解析
  ' 
  Dim dc As Long
  Dim folx As Long
  Dim rx As Long: rx = 0
  Dim ix As Long
  For ix = 0 To UBound(lines)
    Select Case (True)
      Case (InStr(lines(ix), "のディレクトリ") > 0):
        dc = 0
        folx = ix
      Case (InStr(lines(ix), "<DIR>") > 0):
        dc = dc + 1                                   ' <DIR>がいくつあるか数える
      Case (InStr(lines(ix), "個のファイル") > 0):
        If (dc > 2) Then                              ' 2は[.]と[..]のぶん 
          '
          ' 子フォルダを含むフォルダを発見。フォルダ名はlines(folx)に入っている。
          '
          rx = rx + 1                                 ' 書き出し位置+1
          Me.Cells(rx, "A") = lines(folx)             ' セルに書き出してみる
        End If
    End Select
  Next ix

End Sub