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

ファイルのリストアップ

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

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



サンプルコード

コードの貼り付け場所

'+++ 宣言セクション +++   2022/08/02 修正
Private strPS As String 'パスセパレーター格納用

'+++ 実行マクロ +++ Sub Main_Sub() With Application 'フォルダ参照 Dim strDP As String 'フォルダパス格納用 With .FileDialog(msoFileDialogFolderPicker) If .Show = True Then strDP = .SelectedItems(1) End With If strDP = "" Then Exit Sub 'フォルダ参照が「キャンセル」なら終了 'リストアップ .ScreenUpdating = False If File_Listup(strDP) Then MsgBox "リストアップ終了", vbOKOnly + vbInformation .ScreenUpdating = True End With End Sub
'+++ リストアップ関数 ++++++ '【引数】 ' strDP:対象フォルダパス '【戻り値】Bool型 ' True :成功 ' False:失敗 '+++++++++++++++++++++++++++ Private Function File_Listup(ByVal strDP As String) As Boolean 'パスセパレーター strPS = Application.PathSeparator If InStr(1, strDP, strPS) = 0 Then GoTo ERR_1 'フォルダパスにセパレーターがなければ終了 '対象フォルダ 名前・存在確認 If Right$(strDP, 1) = strPS Then strDP = Left$(strDP, Len(strDP) - 1) If Dir(strDP, vbDirectory) = "" Then GoTo ERR_1 '新規ブック 挿入・書き出し Workbooks.Add Cells(1, 1) = "[" & strDP & "]" 'リストアップ処理開始 If Not Listup_Main(2, 2, strDP) Then GoTo ERR_2 File_Listup = True Exit Function ERR_1: MsgBox "選択したフォルダは対象外です", vbOKOnly + vbExclamation, "中止します" Exit Function ERR_2: MsgBox "予期せぬエラーが発生しました", vbOKOnly + vbExclamation, "中止します" End Function
'+++ サブフォルダ名・ファイル名書き出し関数(再帰) +++ '【引数】 ' r :行番号 ' c :列番号 ' strDirPath:対象フォルダパス '【戻り値】 Bool型 ' True :成功 ' False :失敗 '+++++++++++++++++++++++++++++++++++++++++++++++++++ Private Function Listup_Main(ByRef r As Long, ByRef c As Long, _ ByVal strDirPath As String) As Boolean Dim FSO As Object 'ファイルシステムオブジェクト Dim objDir As Object '対象フォルダ Dim F As Object On Error GoTo ErrHandler Set FSO = CreateObject("Scripting.FileSystemObject") Set objDir = FSO.GetFolder(strDirPath) With objDir If 0 < .SubFolders.Count Then 'サブフォルダ数が1以上なら処理実行 For Each F In .SubFolders Cells(r, c).Value = "[" & F.Name & "]" 'フォルダ名の書き出し r = r + 1: c = c + 1 If Not Listup_Main(r, c, strDirPath & strPS & F.Name) Then GoTo ErrHandler 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 Listup_Main = True ErrHandler: On Error GoTo 0 Set objDir = Nothing Set FSO = Nothing End Function



ページトップへ戻る

Excel 汎用コード



Word 汎用コード

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