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

質問

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

回答No.8

merlionXX · ベストアンサー

> やってみましたが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

お礼

ありがとうございました。
うまく行きました。

補足

取得できたデータが階層ごとに列にわかれており非常に使いやすいデータでした。
これをベストアンサーとさせていただきます。

回答No.9

end-u

>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

お礼

なんどもありがとうございます。
いろんな方法があるんですね。
勉強したいと思います。

回答No.7

merlionXX

> 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ドライブを選択して試したらべつの部分でエラーになってしまいました。
原因はまだ究明できていませんが。

お礼

ありがとうございます。
やってみましたがmsoFileDialogFolderPickerがエラーになります。
エラーになる部分は検査対象を選択させる部分 とのいことなのでパスを直接手書きしたら動いたので一応は成功なのですが、手書きじゃない方が便利ですよね。
エクセル2000の場合はどう直せばよいのでしょうか？

回答No.6

piroin654

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

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

お礼

ありがとうございます。
ちょっと難しくて手が出ませんでした。
せっかく教えていただいたのにすみません。

回答No.5

end-u

コマンドプロンプトの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 & "\temp000.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

お礼

ありがとうございます。
ためしてみました。
まず第一階層のフォルダー名の一覧がでました。
次に第二階層以下のフォルダーがあれば、再度第一階層のフォルダー名（その後に第二階層以下も表示されますが）が出ました。
つまり第二階層以下のフォルダーが存在する第一階層名は重複になってしまいます。

回答No.4

piroin654

先ほどは失礼しました。
サブフォルダを含めたフォルダの検索は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 サブフォルダ　再帰

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

お礼

ありがとうございます。
補足に書きましたのでよろしくお願いします。

補足

ありがとうございます。
実は以下のコードをひとからもらいました。
でも
modAPIBrowseForFolder2
の部分が、変数が定義されていないというエラーになってしまうのです。
Windows2000　エクセルも2000です。

' [参照設定]・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
' ルートとなるフォルダの指定(※modAPIBrowseForFolder2.bas)
strPATHNAME = modAPIBrowseForFolder2.BrowseForFolder("ルートフォルダを指定して下さい。", True)
If strPATHNAME = "" Then Exit Sub
' 処理開始
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

'フォルダ単位のサブ処理(再帰動作,引数は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
' 参照OBJECTを破棄
Set objPATH = Nothing
End Sub

回答No.3

piroin654

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

お礼

わかりました。。

回答No.2

piroin654

#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

お礼

なにかわかりませんがありがとうございます。

回答No.1

noname#131542

自分の知識では下記コードだけです
サブフォルダまでは無理だと思われます
エクセル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

お礼

ありがとうございます。
どうしてもサブホルダーまで必要なんです。