トップ > 汎用コード > ファイルのリストアップ

ファイルのリストアップ

指定したフォルダのサブフォルダやファイルをリストアップするマクロです。
元は「備忘録」に載せていたものを簡素化しました。
フォルダ・ファイルの整理や状況に確認に役立つと思います。

マクロを実行するとフォルダ参照のダイアログが表示されます。
フォルダを選択するとリストアップが開始され、新しいブックに記録されていきます。



コードの貼り付け場所

サンプルコード

'///宣言セクション///
Private strDP As String                 'フォルダパス格納用
Private strSep As String                'パスセパレーター格納用
'///

Sub Main_Sub() strDP = "" With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then strDP = .SelectedItems(1) 'フォルダ参照 End With If strDP = "" Then Exit Sub 'フォルダ参照で「キャンセル」なら終了 If File_Listup() Then MsgBox "リストアップ終了", vbOKOnly + vbInformation End Sub
Private Function File_Listup() As Boolean '///パスセパレーター Dim lngSep As Long 'パスセパレーターの位置格納 strSep = Application.PathSeparator '取得 lngSep = InStrRev(strDP, strSep) '位置取得 If lngSep = 0 Then GoSub FIN_1 'フォルダパスにセパレーターがなければ終了 '///対象フォルダ 名前・存在確認 Dim strDN As String 'フォルダ名格納用 If strSep = Right$(strDP, 1) Then strDP = Left$(strDP, Len(strDP) - 1) If Dir(strDP, vbDirectory) = "" Then GoSub FIN_1 If InStr(strDP, strSep) = 0 Then strDN = "" Workbooks.Add '新しいブックの挿入 On Error GoTo FIN_2 If strDN = "" Then Cells(1, 1) = "[" & strDP & "]" Else Cells(1, 1) = "[" & strDN & "]" Call Listup_Main(2, 2, Left$(strDP, lngSep), strDN & strSep) 'リストアップ処理開始 On Error GoTo 0 File_Listup = True Exit Function FIN_1: MsgBox "選択したフォルダは対象外です", vbOKOnly + vbExclamation, "中止します" Exit Function FIN_2: MsgBox "予期せぬエラーが発生しました", vbOKOnly + vbExclamation, "中止します" End Function
'フォルダ、ファイル名を書き出すプロシージャ(再帰) Private Sub Listup_Main(ByRef r As Long, ByRef c As Long, _ ByVal strDirPath As String, ByVal strNewDir As String) Dim F As Object, FSO As Object, objDir As Object On Error GoTo ERR Set FSO = CreateObject("Scripting.FileSystemObject") Set objDir = FSO.GetFolder(strDirPath & strNewDir) With objDir If 0 < .SubFolders.Count Then 'サブフォルダ数が1以上なら処理実行 For Each F In .SubFolders Cells(r, c).Value = "[" & F.Name & "]" 'フォルダ名の書き出し c = c + 1: r = r + 1 Call Listup_Main(r, c, strDirPath & strNewDir, F.Name & strSep) c = c - 1 Next End If If 0 < .Files.Count Then 'ファイル数が1以上なら処理実行 For Each F In .Files Cells(r, c).Value = F.Name 'ファイル名の書き出し r = r + 1 Next End If End With On Error GoTo 0 ERR: Set objDir = Nothing Set FSO = Nothing End Sub

ページトップへ戻る

Excel 汎用コード

Word 汎用コード

Copyright(C) 2009- 坂江 保 All Rights Reserved.