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

ファイルのリストアップ

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

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



サンプルコード

コードの貼り付け場所

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

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



ページトップへ戻る

Excel 汎用コード



Word 汎用コード

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