エクセルVBAでフォルダー名を取得

Question

たとえばEドライブ（社内の共有ドライブ）の全フォルダー名（その下のすべてのサブフォルダーを含む）を取得し、ワークシートに書き出すにはどのようなコードを書けばよいのでしょうか？
（フォルダー内のファイル名は不要です）
よろしくお願いします。

merlionXX · Accepted Answer

> やってみましたがmsoFileDialogFolderPickerがエラーになります。

それは失礼しました。
自宅の2003でテストしたため、エラーにならず、気づきませんでした。
今、2000で試しました。
これでどうでしょう？
あくまでご提示のコードのフォルダーの指定部分だけを2000で動くように修正しただけです。
再帰動作等、他の部分はわたしもよく理解できていません。現にCドライブで試すとエラーになりました。
(^^;;

' [参照設定]・Microsoft Scripting Runtime
Option Explicit
Private g_cntFILE As Long
Private g_cntPATH As Long

Sub SEARCH_FOLDER()
　　Dim objFSO As FileSystemObject
　　Dim strPATHNAME As String
　　Dim myObj As Object
　　Dim myDir As String
　　
　　Set myObj = CreateObject("Shell.Application"). _
　　BrowseForFolder(0, "フォルダを選択してください", 0)
　　If myObj Is Nothing Then Exit Sub
　　　　If myObj = "デスクトップ" Then
　　　　　　myDir = CreateObject("WScript.Shell").SpecialFolders("Desktop")
　　　　Else
　　　　　　myDir = myObj.Items.Item.Path
　　　　End If
　　strPATHNAME = myDir
　　Cells.ClearContents
　　Set objFSO = New FileSystemObject
　　Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME), 0, 0)
　　Set objFSO = Nothing
　　MsgBox "処理が完了しました。" & vbCr & vbCr & _
　　"フォルダ数=" & g_cntPATH & vbCr, vbInformation
End Sub

'フォルダ単位のサブ処理(再帰動作,引数はFile-Object,行,カラム)
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, ByRef GYO As Long, ByVal COL As Long)
　　Dim objPATH2 As Folder
　　g_cntPATH = g_cntPATH + 1 '参照フォルダ数を加算
　　GYO = GYO + 1 ' 行を加算
　　COL = COL + 1 ' カラムを加算
　　Cells(GYO, COL).Value = "[" & objPATH.Name & "]"
　　For Each objPATH2 In objPATH.SubFolders 'サブフォルダを探索するループ処理
　　　　Call SEARCH_SUB_FOLDER(objPATH2, GYO, COL) 'フォルダ単位のサブ処理(再帰呼び出し)
　　Next objPATH2
　　Set objPATH = Nothing ' 参照OBJECTを破棄
End Sub

end-u · Answer

>re:#5
>つまり第二階層以下のフォルダーが存在する第一階層名は重複になってしまいます。
『..フォルダパスを書き出すサンプル。』ですからね。
一旦シートに書き出せば、いかようにも加工できるかと思ってましたが。
Sub try_3()
　　Const arg = "tree ""c:"""
　　Dim ret As String
　　Dim v() As String
　　ret = CreateObject("WScript.Shell").Exec("%ComSpec% /c " & arg).StdOut.ReadAll
　　v = Split(ret, vbCrLf)
　　Sheets.Add.Cells(1).Resize(UBound(v) + 1).Value = Application.Transpose(v)
End Sub
こんなのもありますし。

最終的にどんな形式で書き出したいのか、に合わせて工夫してください。
Sub try_4()
　　Dim arg　As String
　　Dim brf　As Object
　　Dim wsh　As Object
　　Dim ret　As String
　　Dim v()　As String
　　Dim r　　As Range
　　Dim i　　As Long
　　Dim n(1) As Long
　　Dim ary(1 To 255)

Set brf = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, "SelectFolder", 0)
　　If brf Is Nothing Then Exit Sub
　　arg = Replace(brf.self.Path & "", "\", "")
　　arg = "dir """ & arg & """ /a:d/b/s"
　　Set wsh = CreateObject("WScript.Shell")
　　ret = wsh.Exec("%ComSpec% /c " & arg).StdOut.ReadAll
　　v = Split(ret, vbCrLf)
　　Set r = Sheets.Add.Cells(1).Resize(UBound(v) + 1)
　　r.Value = Application.Transpose(v)
　　r.Sort Key1:=r.Cells(1)
　　With r.Offset(, 1)
　　　　.Value = r.Value
　　　　.Replace "*", "", xlPart
　　　　n(1) = 2
　　　　For i = 1 To 255
　　　　　　n(0) = i
　　　　　　ary(i) = n
　　　　Next
　　　　.TextToColumns DataType:=xlDelimited, _
　　　　　　　　　　　 TextQualifier:=xlDoubleQuote, _
　　　　　　　　　　　 ConsecutiveDelimiter:=False, _
　　　　　　　　　　　 Tab:=False, _
　　　　　　　　　　　 Semicolon:=False, _
　　　　　　　　　　　 Comma:=False, _
　　　　　　　　　　　 Space:=False, _
　　　　　　　　　　　 Other:=True, _
　　　　　　　　　　　 OtherChar:="", _
　　　　　　　　　　　 FieldInfo:=ary
　　End With

Set r = Nothing
　　Set brf = Nothing
　　Set wsh = Nothing
End Sub

merlionXX · Answer

> modAPIBrowseForFolder2
> の部分が、変数が定義されていないというエラーになってしまうのです。

わたしも2000です。
試したら同様にエラーになりました。
で、自宅に帰り2003で試してもやはり同じエラーが出ました。
バージョンの違いではなさそうです。

エラーになる部分は検査対象を選択させる部分ですよね。
ならば、その部分を

Sub SEARCH_FOLDER02()
　　Dim objFSO As FileSystemObject
　　Dim strPATHNAME As String
　　'対象とするフォルダの指定
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If .Show = True Then
　　　　　　strPATHNAME = .SelectedItems(1)
　　　　Else
　　　　　　MsgBox "キャンセル"
　　　　　　Exit Sub
　　　　End If
　　End With
' 処理開始
　　Cells.ClearContents
　　Set objFSO = New FileSystemObject
　　' ルートフォルダから探索開始
　　Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME), 0, 0)
　　' 参照OBJECTを破棄
　　Set objFSO = Nothing
　　' 処理完了(結果表示)
　　MsgBox "処理が完了しました。" & vbCr & vbCr & _
　　"フォルダ数=" & g_cntPATH & vbCr, vbInformation
End Sub

と変えてみました。
これならその部分ではエラーにならないはずです。
MyDocumentをためしたらちゃんと所得できました。
ただ、Cドライブを選択して試したらべつの部分でエラーになってしまいました。
原因はまだ究明できていませんが。

piroin654 · Answer

modAPIBrowseForFolder2 は初めて聞きましたが、
検索すると一つのサイトが見つかりました。この
サイトに補足されたコードと完成されたExcelファイルが
ありました。
以下です。確認してみてください。

サイト
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_120.html
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html

ファイル
http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_110.html

一応、こちらで動作の確認はしてみました。

end-u · Answer

コマンドプロンプトのdirコマンドを使えば比較的簡単です。
シート追加しA列にフォルダパスを書き出すサンプル。

Sub try()
　　Const arg = "dir ""e:"" /a:d/b/s"
　　Dim wsh As Object
　　Dim ret As String
　　Dim v() As String

Set wsh = CreateObject("WScript.Shell")
　　ret = wsh.Exec("%ComSpec% /c " & arg).StdOut.ReadAll
　　v = Split(ret, vbCrLf)
　　Sheets.Add.Cells(1).Resize(UBound(v) + 1).Value = Application.Transpose(v)
　　Set wsh = Nothing
End Sub
フォルダごとにセルを分けたければメニュー[データ]-[区切り位置]でA列を『\』で区切れば良いです。

一瞬表示されるコンソールが気になるなら一旦テキストファイルに書き出します。
Sub try_2()
　　Const arg = "dir ""e:"" /a:d/b/s"
　　Dim wrk As String
　　Dim v() As String
　　Dim n　 As Long

wrk = Application.DefaultFilePath & "	emp000.dat"
　　CreateObject("WScript.Shell") _
　　　　　　.Run "%ComSpec% /c " & arg & ">" & """" & wrk & """", 0, True
　　n = FreeFile
　　Open wrk For Input As #n
　　v = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
　　Close #n
　　Kill wrk
　　Sheets.Add.Cells(1).Resize(UBound(v) + 1).Value = Application.Transpose(v)
End Sub

piroin654 · Answer

先ほどは失礼しました。
サブフォルダを含めたフォルダの検索はWEB上に
たくさんサンプルがあります。

http://www7.big.or.jp/~pinball/discus/vb/63655.html
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=22592;id=excel

など、まだあります。要点は再帰関数を作って
再帰的にフォルダを下層に下っていくことです。

excel サブフォルダ　再帰

でググるといろいろ出てきます。コードは
長くなるのでサンプルを探して試してみてください。

piroin654 · Answer

＃2です。間違って他の質問の回答をしてしましました。
#2はなかったことにしてください。

piroin654 · Answer

#4です。ついでなので最終列の取得も変更しておきます。

Sub test5()
Dim L1 As Long
Dim L2 As Long
Dim R1 As Long
Dim x As Long
Dim y As Long

R1 = 2
L2 = 2
x = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row '最終行
y = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column '最終列
For L1 = 2 To x
'A列のデータが尽きたところで終了
If Worksheets("Sheet1").Cells(L1, 1).Value = "" Then
Exit Sub
End If

For R1 = 2 To y
'A1のデータが尽きたところでループを抜ける
If Worksheets("Sheet1").Cells(1, R1).Value = "" Then
Exit For
End If

'A列に結合したデータを表示
Worksheets("Sheet2").Cells(L2, 1).Value = Worksheets("Sheet1").Cells(L1, 1).Value & _
Worksheets("Sheet1").Cells(1, R1).Value
'B列にデータを表示
Worksheets("Sheet2").Cells(L2, 2).Value = Worksheets("Sheet1").Cells(L1, R1).Value
L2 = L2 + 1
Next R1
Next L1
End Sub

shornet · Answer

自分の知識では下記コードだけです
サブフォルダまでは無理だと思われます
エクセルVBAの全コードが記載されてる１０００ページくらいに及ぶ解説
にも載ってません

なお参照設定でmicrosoft scripting runtimeを追加してください

Dim myFSO As New FileSystemObject
Dim myFolders As Folders

Dim myFolder As Folder

Dim i As Integer

Set myFolders = myFSO.GetFolder("　").SubFolders
 　　　　　　　　　　　　　　　　　　かっこの中にはドライブ指定する
 
  i = 1
  
 For Each myFolder In myFolders
 
    i = i + 1
    Cells(i + 1, 1) = myFolder.Name
    
  Next

エクセルVBAでフォルダー名を取得

> やってみましたがmsoFileDialogFolderPickerがエラーになります。

この回答への補足

>re:#5

> modAPIBrowseForFolder2

modAPIBrowseForFolder2 は初めて聞きましたが、

コマンドプロンプトのdirコマンドを使えば比較的簡単です。

先ほどは失礼しました。

この回答への補足

＃2です。

#4です。

自分の知識では下記コードだけです

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング