Ｐａｇｅ 199 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼一つ下のサブフォルダ名のみ取得したい カド 02/10/13(日) 6:40 ┗Ｆｉｌｅ System Object で・・・ ichinose 02/10/13(日) 7:47 ┗Re:Ｆｉｌｅ System Object で・・・ カド 02/10/13(日) 10:11 ┗Re:元のコードからの変更 Hirofumi 02/10/13(日) 14:15 ┗Re:元のコードからの変更 Hirofumi 02/10/13(日) 14:30 ┗Re:元のコードからの変更 カド 02/10/13(日) 18:37 ─────────────────────────────────────── ■題名 ： 一つ下のサブフォルダ名のみ取得したい ■名前 ： カド ■日付 ： 02/10/13(日) 6:40 -------------------------------------------------------------------------
| こんにちわ〜 以前サブフォルダ以下のファイル名も取得する以下の コードを教えていただきました。（No12076） 今回は、ファイル名ではなく、一つ下までのサブフォルダ名を 取得する方法を教えてください。（２つより下の階層は不要） ************************************************************************ '別な方法も有るようですが 'こんなのでも、善いのかな？ 'DirTestを実行すると､strDirPathで指定したPath以下のフォルダから '"*.xls"のファイルをSheet1に列挙します、FilesListの第３引数にTrueを 'Falseにすればサブフォルダは探しません Public Sub DirTest() Dim i As Long Dim vntFileName As Variant Dim strDirPath As String strDirPath = ThisWorkbook.Path vntFileName = FilesList(strDirPath, "*.xls", True) With Worksheets("Sheet1") For i = 0 To UBound(vntFileName) .Cells(i + 1, 1).Value = vntFileName(i) Next i End With End Sub Public Function FilesList(ByVal strFilesPath As String, _ ByVal strSearchFile As String, _ Optional blnSubDir As Boolean = False) As Variant Dim strData() As String ReDim strData(0) FileListing strFilesPath, strSearchFile, strData(), blnSubDir FilesList = strData() End Function Private Sub FileListing(ByVal strFilesPath As String, _ ByVal strSearchFile As String, _ strData() As String, blnSubDir As Boolean) Dim i As Long Dim j As Long Dim strFileName As String Dim strDirList() As String '結果用配列の書き込み位置を取得 If strData(UBound(strData)) = "" Then i = UBound(strData) Else i = UBound(strData) + 1 End If 'パスの最後に\を付加 If Right(strFilesPath, 1) <> "\" Then strFilesPath = strFilesPath & "\" End If 'ディレクトリ内の全ての標準ファイルを列挙 strFileName = Dir(strFilesPath & strSearchFile) Do Until strFileName = "" ReDim Preserve strData(i) strData(i) = strFilesPath & strFileName i = i + 1 strFileName = Dir Loop If blnSubDir Then 'サブディレクトリの一時的なリストを作成 strFileName = Dir(strFilesPath, vbDirectory) Do Until strFileName = "" '現在のディレクトリと親ディレクトリを無視 If strFileName <> "." And strFileName <> ".." Then 'ディレクトリ以外を無視 If GetAttr(strFilesPath & strFileName) _ And vbDirectory Then j = j + 1 ReDim Preserve strDirList(j) strDirList(j) = strFilesPath & strFileName End If End If strFileName = Dir Loop '各ディレクトリを再帰的に処理 For i = 1 To j FileListing strDirList(i), strSearchFile, strData(), True Next i End If End Sub |
| ▼カド さん： おはようございます。 >以前サブフォルダ以下のファイル名も取得する以下の >コードを教えていただきました。（No12076） > >今回は、ファイル名ではなく、一つ下までのサブフォルダ名を >取得する方法を教えてください。（２つより下の階層は不要） ＦＳＯを使いました。 '========================================== Sub test() Dim f_name As String f_name = "D:\EXCELファイル" i = 1 Set ffs = get_folders(f_name) If Not ffs Is Nothing Then For Each fold In ffs Cells(i, 1).Value = fold.Name Cells(i, 2).Value = fold.Path i = i + 1 Next End If Set ffs = Nothing End Sub '=========================================== Function get_folders(f_fold As String) As Object On Error Resume Next Set get_folders = Nothing Set get_folders = CreateObject("Scripting.FileSystemObject").getfolder(f_fold).subfolders On Error GoTo 0 End Function |
| ▼ichinose さん： こんにちわ〜。朝早くから回答ありがとうございます。 当サイトは、朝早くから夜遅くまで、誰かが対応してくれるので大変助かります。 さて,本題に入りますが、私の説明がまずく正しく意図が伝わらなかったようなので、 再度説明いたします。 ichinoseさんの回答に対し、さらにもう一つ下の階層のフォルダ名を取得する方法を お教えください。 過去の例でも、”ＦＳＯを使いました”とことわり書きをしてある回答をよくみかけますが、 残念ながらＦＳＯって何？というレベルです。これを機に勉強したいと思います。 さらに、勝手なお願いですみませんが、下記コードを改良した場合の方法についても、 お分かりの方が見えたらお教えください。 再帰のループに頭がついて行けないにもかかわらず、再帰のコードに通常のプログラムとは 違う魅力を感じています。 以前教えていただいたサブフォルダ以下のファイル名も取得するコード（No12076） ************************************************************************************* '別な方法も有るようですが 'こんなのでも、善いのかな？ 'DirTestを実行すると､strDirPathで指定したPath以下のフォルダから '"*.xls"のファイルをSheet1に列挙します、FilesListの第３引数にTrueを 'Falseにすればサブフォルダは探しません Public Sub DirTest() Dim i As Long Dim vntFileName As Variant Dim strDirPath As String strDirPath = ThisWorkbook.Path vntFileName = FilesList(strDirPath, "*.xls", True) With Worksheets("Sheet1") For i = 0 To UBound(vntFileName) .Cells(i + 1, 1).Value = vntFileName(i) Next i End With End Sub Public Function FilesList(ByVal strFilesPath As String, _ ByVal strSearchFile As String, _ Optional blnSubDir As Boolean = False) As Variant Dim strData() As String ReDim strData(0) FileListing strFilesPath, strSearchFile, strData(), blnSubDir FilesList = strData() End Function Private Sub FileListing(ByVal strFilesPath As String, _ ByVal strSearchFile As String, _ strData() As String, blnSubDir As Boolean) Dim i As Long Dim j As Long Dim strFileName As String Dim strDirList() As String '結果用配列の書き込み位置を取得 If strData(UBound(strData)) = "" Then i = UBound(strData) Else i = UBound(strData) + 1 End If 'パスの最後に\を付加 If Right(strFilesPath, 1) <> "\" Then strFilesPath = strFilesPath & "\" End If 'ディレクトリ内の全ての標準ファイルを列挙 strFileName = Dir(strFilesPath & strSearchFile) Do Until strFileName = "" ReDim Preserve strData(i) strData(i) = strFilesPath & strFileName i = i + 1 strFileName = Dir Loop If blnSubDir Then 'サブディレクトリの一時的なリストを作成 strFileName = Dir(strFilesPath, vbDirectory) Do Until strFileName = "" '現在のディレクトリと親ディレクトリを無視 If strFileName <> "." And strFileName <> ".." Then 'ディレクトリ以外を無視 If GetAttr(strFilesPath & strFileName) _ And vbDirectory Then j = j + 1 ReDim Preserve strDirList(j) strDirList(j) = strFilesPath & strFileName End If End If strFileName = Dir Loop '各ディレクトリを再帰的に処理 For i = 1 To j FileListing strDirList(i), strSearchFile, strData(), True Next i End If End Sub |
| >さらに、勝手なお願いですみませんが、下記コードを改良した場合の方法についても、 >お分かりの方が見えたらお教えください。 こんな物で善いかな？ 階層数はFilesListの第二引数で決められます 元のコードと引数等が細かく違っていますので気をつけて下さい Public Sub DirTest() Dim i As Long Dim vntFileName As Variant Dim strDirPath As String strDirPath = ThisWorkbook.Path vntFileName = FilesList(strDirPath, 1) With Worksheets("Sheet1") For i = 0 To UBound(vntFileName) .Cells(i + 1, 1).Value = vntFileName(i) Next i End With End Sub Public Function FilesList(ByVal strFilesPath As String, _ Optional lngSubDir As Long = 1) As Variant ' strFilesPath: 探し始めるフォルダ名 ' lngSubDir: 探す階層数 Dim strData() As String ReDim strData(0) '探し始めるフォルダを代入（必要が無ければ削除） strData(0) = strFilesPath 'フォルダをリストアップ FileListing strFilesPath, strData(), lngSubDir FilesList = strData() End Function Private Sub FileListing(ByVal strFilesPath As String, _ strDirList() As String, lngSubDir As Long) Dim i As Long Dim j As Long Dim lngNow As Long Dim strFileName As String Dim strDirListTmp() As String '結果用配列の書き込み位置を取得 If strDirList(UBound(strDirList)) = "" Then i = UBound(strDirList) Else i = UBound(strDirList) + 1 End If 'パスの最後に\を付加 If Right(strFilesPath, 1) <> "\" Then strFilesPath = strFilesPath & "\" End If 'サブディレクトリの結果リストと、一時的なリストを作成 j = 1 strFileName = Dir(strFilesPath, vbDirectory) Do Until strFileName = "" '現在のディレクトリと親ディレクトリを無視 If strFileName <> "." And strFileName <> ".." Then 'ディレクトリ以外を無視 If GetAttr(strFilesPath & strFileName) _ And vbDirectory Then ReDim Preserve strDirList(i) ReDim Preserve strDirListTmp(j) '結果リストに追加 strDirList(i) = strFilesPath & strFileName '一時的なリストに追加 strDirListTmp(j) = strDirList(i) i = i + 1 j = j + 1 End If End If strFileName = Dir Loop 'ディレクトリの階層を一つ下げる lngSubDir = lngSubDir - 1 '指定階層数になるまで再帰 If lngSubDir > 0 Then '各ディレクトリを再帰的に処理 For i = 1 To j - 1 lngNow = lngSubDir FileListing strDirListTmp(i), strDirList(), lngNow Next i End If End Sub |
| このままで実行するとichinoseさんの回答と同じ階層までですので 以下の様に第二引数に2を与えて下さい vntFileName = FilesList(strDirPath, 1) 上記を vntFileName = FilesList(strDirPath, 2) の様に |
| ▼Hirofumi さん： 作動を確認しました。私のリクエストに対し完璧です。ありがとうございます。 これからコードの内容を理解するつもりですが、出来るかは？です。 今後ともよろしく〜 |