• ベストアンサー

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

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

質問者が選んだベストアンサー

  • ベストアンサー
  • merlionXX
  • ベストアンサー率48% (1930/4007)
回答No.8

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

emaxemax
質問者

お礼

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

emaxemax
質問者

補足

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

その他の回答 (8)

  • end-u
  • ベストアンサー率79% (496/625)
回答No.9

>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

emaxemax
質問者

お礼

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

  • merlionXX
  • ベストアンサー率48% (1930/4007)
回答No.7

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

emaxemax
質問者

お礼

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

  • piroin654
  • ベストアンサー率75% (692/917)
回答No.6

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 一応、こちらで動作の確認はしてみました。

emaxemax
質問者

お礼

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

  • end-u
  • ベストアンサー率79% (496/625)
回答No.5

コマンドプロンプトの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

emaxemax
質問者

お礼

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

  • piroin654
  • ベストアンサー率75% (692/917)
回答No.4

先ほどは失礼しました。 サブフォルダを含めたフォルダの検索は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 サブフォルダ 再帰 でググるといろいろ出てきます。コードは 長くなるのでサンプルを探して試してみてください。

emaxemax
質問者

お礼

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

emaxemax
質問者

補足

ありがとうございます。 実は以下のコードをひとからもらいました。 でも 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

  • piroin654
  • ベストアンサー率75% (692/917)
回答No.3

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

emaxemax
質問者

お礼

わかりました。。

  • piroin654
  • ベストアンサー率75% (692/917)
回答No.2

#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

emaxemax
質問者

お礼

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

noname#131542
noname#131542
回答No.1

自分の知識では下記コードだけです サブフォルダまでは無理だと思われます エクセルVBAの全コードが記載されてる1000ページくらいに及ぶ解説 にも載ってません なお参照設定で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

emaxemax
質問者

お礼

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

関連するQ&A

  • ExcelVBAでサブフォルダ名などを取得したい

     ExcelVBAで、Dドライブ内の特定のフォルダ(D:\My Documents等)の中にある全てのフォルダ名やファイル名を取得したいのですが、方法が分かりません。  Dドライブのすぐ下にあるフォルダはDirで取得できるようなのですが、サブフォルダ名が取得できないのです。  具体的にどのように書いたらよいかお教えいただけるとうれしいです。  よろしくお願いします。

  • エクセル2007VBAでフォルダ名とファイル名を

    取得したいのです。 あるフォルダ内にマクロのファイルと、複数のサブフォルダ及びその中の複数ファイルがあり 添付画像の通り、サブフォルダ名とファイル名、拡張子を取得したいのです。 どのようにすれば良いでしょうか、、ご教示下さい。

  • フォルダ内にあるファイル名を取得するVBA

    エクセル2010を使用しています。 VBA(マクロ)で以下の作業を実行したいと考えていますが、 初心者につき、ご教示いただけますでしょうか。 「マクロ」ファイルにある「実行」Sheetというにある「実行」ボタンで L2に入力したパス内にあるファイル(.xlsや.xlsmや.xlsbが混在しますが、基本的には全てエクセルファイル)のファイル名を K8から下へ取得したいのですが・・ 参考にしたコードでは うまく動作しませんでした。 以下では、L2のパスを参照するのも組めていないため、コード内に直接パスを書き込んでいますが 実際は、パスを変動させて使いたいので、L2を参照できるようになると助かります。 ※パスは、質問用に仮置きで「パス」としています。 Sub Sample() Dim buf As String, cnt As Long Const Path As String = "パス" buf = Dir(Path & "*.*") Do While buf <> "" cnt = cnt + 8 Cells(cnt, 11) = buf buf = Dir() Loop End Sub また、このコードでは 実行ファイル自体のファイル名も取得してしまうようなので、 実行ファイル以外のファイル名を取得したいです。 ご指導のほど、よろしくお願い致します。

  • Excel VBAでフォルダー・ファイル名の取得

    いつもお世話になります。 Excelで、決められたディレクトリーの下にあるフォルダー名とファイル名を取得して Excelに表示したいのですが、調べたのですがよくわかりませんですた。 決められたディレクトリーは固定で、その下には複数フォルダーがあります。 よろしくお願い致します。

  • エクセルのマクロでファイルのシート名一覧を取得したい

    特定フォルダ内にエクセルのファイルが複数あります。 エクセルのファイル名の取得は「Filesearch」を使い取得出来ました。 更にそのファイルの中にあるシート名を取得し、シート名の一覧を ワークシートに貼り付けたいと考えています。 よろしくご教授ください。

  • フォルダ名だけを取得するVBA

    VBAを使ったエクセルテンプレート適用ツールを作成しているのですが そのVBAのことで教えてください。 現在自作のフォーム上にあるテキストボックスにフルパスが入っているとします(添付図参照)。 *この前提は必須と考えてください。 次に作成ボタンをクリックすると Step1 新しいブックが開かれ行幅や書式などが自動で調整されます。 Step2 ブックの保存ダイアログが自動で開きます。     ただし、保存ダイアログが開いた時点で自作フォーム中の     テキストボックスで指定したフルパスに移動しており、     且つ移動先のフォルダ名(<-注意!!フルパス名ではありません!!)と     同じ文字列をファイル名入力欄に自動で入力されるようにします。    ex) D:\MyProject\Project01\TaskA\にブックを作成し保存する場合、      保存ダイアログのファイル名欄にTaskAとだけ書く。 マクロ自体はここでストップし、これ以降はユーザーがそのファイルメモで 保存してよいかどうかを判断し、問題なければ手動でダイアログ上の「保存」ボタンを押します。 問題はStep2で、保存先のフォルダ名と同じ文字列を保存ダイアログのファイル名に記入するには どのようなコードを書いたらよいでしょうか。 私自身としては下記の二案を考えているのですがそれぞれについて疑問があるので教えてください。 案1 作成ボタンを押した時点でテキストボックスに書かれているフルパスの文字列から   末尾にあるフォルダ名だけを取得して変数に代入し、これを保存ダイアログの   ファイル名欄に反映させる。   疑問:テキストボックスのValue値に書かれているフルパスを示す文字列から      末尾のフォルダ名だけを取得するためのコードは何と書けばよいのでしょうか? 案2 ブックの保存ダイアログが開いて保存先のパスに移動してから今保存ダイアログで    開いているフォルダ名を取得する。    疑問:今アクティブになっているブックが保存されているフォルダ名だけを取得する    方法なら確かあったような気がしています。    しかし今保存ダイアログで表示されているフォルダ名を取得するコードは何と    書けばよいのでしょうか?    そもそもそういったコードや操作自体VBAにあるのでしょうか?

  • ExcelのVBAでの複数階層からのフォルダ名の取得

    ExcelのVBAでの複数階層からのフォルダ名の取得 下記階層に対して以下の処理をExcelのVBAで行うにはどしたら良いか、 申し訳ありませんが、どうか教えて頂きたく思います。 C:\test1   ├\aaa\ddd   │   ├\xxx1\   │   └\yyy2\   │   ├\bbb\ddd   │   └\xxx3\   │   │   └\ccc\ddd       ├\xxx4\       ├\xxx5\       └\zzz6\ 1 C:\test1を指定する 2 1で指定した中にある各\dddフォルダ内にあるフォルダ名を順に取得する 3 2で取得したフォルダ名をExcelのSheet1のA1から順に書き出す Excel   A    B    C    D    E 1 xxx1 2 yyy2 3 xxx3 4 xxx4 5 xxx5 6 zzz6 7 8 9  Sheet1 Sheet2 Sheet3 勉強不足で申し訳ありません。 どうぞ宜しくお願い致します。

  • VBA 一つのフォルダの中のフォルダ名とファイル名

    一つのフォルダの中のフォルダ名とファイル名を取得したい場合は ************************************** Sub test() Dim MyFileName As String Dim MyFolderName As String Dim myFSO As Object Dim MyFolder As Scripting.Folder MyFolderName = "C:\" 'フォルダを取得 MyFileName = Dir(MyFolderName & "*.*") Do While MyFileName <> "" Debug.Print MyFileName MyFileName = Dir() Loop 'ファイルを取得 Set myFSO = CreateObject("Scripting.FileSystemObject") With myFSO With .GetFolder(MyFolderName) For Each MyFolder In .SubFolders Debug.Print MyFolder.Name Next End With End With Set myFSO = Nothing End Sub ************************************** の様に ファイル名・フォルダ名をそれぞれループして取得しないとダメでしょうか? もうちょっとスマートなコードはありますか?

  • フォルダ内のファイル名を取得する

    windows 7なのですが、フォルダ内にあるファイル名をテキストとしてすべて一括で取得する方法はないでしょうか? また、フォルダの中にさらに複数のフォルダがあっても、上の階層のフォルダからすべてファイル名を取得する方法はないでしょうか? よろしくお願いいたします。

  • フォルダ内のサブフォルダ名やファイル名の取得

    VB初心者です。 あるフォルダ内のサブフォルダ名や数、ファイル名を取得したいのですが・・・ コントロールのDirListBoxを使用するか、Dir関数を使用したいのですが、上手くできません。 ご存知の方、教えてください

専門家に質問してみよう