『マクロ ファイル一覧取得』（はつ）
先任が残したフォルダ一覧を取得するファイルがあります
これを階層でファイル名まで取得することはできるのでしょうか？
マクロが初めてで調べても何をどうしたらよいのかチンプンカンプンです
Option Explicit
' 起点フォルダを記載するセル
Private Const CELL_BASE_FOLDER As String = "B10"
' -------------------------------------------
' フォルダ一覧作成
' -------------------------------------------
' ---- 起動: フォルダ一覧作成
Sub get_folder_list()
' 起点とするフォルダを選択
Dim base_folder_path As String
base_folder_path = folder_pick("作成するフォルダ一覧の対象フォルダを指定してください。")
' フォルダが指定された場合処理開始
If base_folder_path <> "" Then
' サブフォルダを再帰的に一覧取得
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim folder_list As Variant ' サブフォルダリスト（配列）
get_sub_folders fso.GetFolder(base_folder_path), folder_list
Set fso = Nothing
' シートに転記
write_folder_list ActiveWorkbook.ActiveSheet, base_folder_path, folder_list
Else
' フォルダ指定しなかった場合の動作
End If
End Sub
' ---- 再帰的にサブフォルダを検索
' TARGET: 検索対象のフォルダオブジェクト
' arr: フォルダリスト配列（参照渡し）
Private Sub get_sub_folders(TARGET As Object, ByRef arr As Variant)
Dim sub_folder As Object
For Each sub_folder In TARGET.SubFolders
push_arr sub_folder.Path, arr
get_sub_folders sub_folder, arr
Next
End Sub
' ---- シートにフォルダリストを出力
' ws: 出力するシート
' base_folder_path: ベースフォルダ
' folder_list: フォルダリスト配列
Private Sub write_folder_list(ws As Worksheet, base_folder_path As String, folder_list As Variant)
Dim i As Long
Dim j As Long
Dim path_array As Variant
' 起点とするセル
With ws.Range(CELL_BASE_FOLDER)
' ベースとしたフォルダをそのセルに記載
.Value = base_folder_path
' 以下ループしながらセルに出力（offset で起点セルからの相対位置をずらしながら出力）
For i = LBound(folder_list) To UBound(folder_list)
' 配列要素からベースフォルダ部分を削除し、残りを \ で分割して配列化
path_array = Empty
path_array = Split(Replace(folder_list(i), base_folder_path & "\", ""), "\")
' 念のために配列化されているかをチェック
If IsArray(path_array) Then
' セルに記載
.Offset(i - LBound(folder_list) + 1, 0).Value = base_folder_path
For j = LBound(path_array) To UBound(path_array)
.Offset(i - LBound(folder_list) + 1, j - LBound(path_array) + 1).Value = path_array(j)
Next
End If
Next
End With
Set ws = Nothing
End Sub
' -------------------------------------------
' フォルダ作成
' -------------------------------------------
' ---- 起動: フォルダ作成
Sub create_folders()
' 元とするシート
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
' 作成先のフォルダを取得
Dim dest_folder_path As String
dest_folder_path = folder_pick("サブフォルダを作成するフォルダを指定してください。")
' 作成先のフォルダを指定された場合
If dest_folder_path <> "" Then
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
' 指定したフォルダ内が空でない場合は念のため終了
If Dir(fso.BuildPath(dest_folder_path, "*")) <> "" Then
MsgBox "指定したフォルダ内が空ではないようです。安全のため処理を中止します。", vbOKOnly, "中止"
Exit Sub
End If
' サブフォルダ作成
' =================================================
' Excelのシートからデータ取得
With ws.Range(CELL_BASE_FOLDER)
Dim target_path As String
Dim i As Long ' 相対行に相当
Dim j As Long ' 相対列に相当
' 行の初め（フォルダ一覧を作成した際の検索基点フォルダ名が入っているはず）が空になるまで行方向にループ
i = 1
Do Until .Offset(i, 0).Value = ""
' フォルダ作成する基点フォルダパスを設定
target_path = dest_folder_path
' 列（＝フォルダ階層）がなくなるまで列方向にループ
' 列の上位からたどっているため、パスを追記しながらフォルダの存在をチェックしなければ作る、を繰り返す
j = 1
Do Until .Offset(i, j).Value = ""
target_path = fso.BuildPath(target_path, .Offset(i, j).Value)
If Not (fso.FolderExists(target_path)) Then MkDir target_path
j = j + 1
Loop
i = i + 1
Loop
End With
Set fso = Nothing
Set ws = Nothing
Else
' フォルダ指定をキャンセルした場合の処理
End If
End Sub
' -------------------------------------------
' 共通関数
' -------------------------------------------
' ---- フォルダ選択ダイアログ
Private Function folder_pick(Optional dialog_title As String = "") As String
Dim tmpRet As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If dialog_title <> "" Then .Title = dialog_title
If .Show = True Then
tmpRet = .SelectedItems(1)
Else
tmpRet = ""
MsgBox "処理を中止しました。", vbOKOnly, "中止"
End If
End With
folder_pick = tmpRet
End Function
' ---- 配列の最後にデータ追加
Private Sub push_arr(DATA As Variant, ByRef arr As Variant)
If IsArray(arr) Then
ReDim Preserve arr(UBound(arr) + 1)
Else
ReDim arr(0)
End If
' 配列に代入
If IsObject(DATA) Then ' データがオブジェクトの場合
Set arr(UBound(arr)) = DATA
Else ' データがオブジェクトではない場合
arr(UBound(arr)) = DATA
End If
End Sub
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
>先任が残したフォルダ一覧を取得するファイルがあります
それを提示してください。 （マナ） 2023/09/28(木) 15:34:56
できるに決まってます。
＞マクロが初めてで調べても何をどうしたらよいのかチンプンカンプンです
呼ばれていないプロシージャまでくっつけてくるくらいチンプンカンプンでは困りもの。
とりあえずヒントだけ。write_folder_list プロシージャに手を入れる。
もっと詳しく回答してくれる親切な人がいるやも知れないが。
（xlg） 2023/09/28(木) 15:47:07
１．コマンドプロンプトで、取得したい一番上の階層までカレントディレクトリを移動（cd コマンド使用）。
２．tree /F > syutoku.txt と入力しEnter。
するとそこのフォルダに syutoku.txt というテキストファイルが出来上がるので、あとは煮るなり焼くなり。
Excelとは違うけど、とりあえずの取得だけならめちゃ簡単だし。
（知らんけど） 2023/09/28(木) 16:11:17
失礼しました。提示されていましたね。
Sub test()
Dim fdg As FileDialog
Dim p As String
Dim cmd As String, s
Dim r As Range
Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
If Not fdg.Show Then Exit Sub
p = fdg.SelectedItems(1)
cmd = "cmd /c dir """ & p & "\*.*"" /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
Set r = Worksheets.Add.Range("B10").Resize(UBound(s))
r.Value = Application.Transpose(s)
r.Replace p, "", xlPart
r.TextToColumns Destination:=r, DataType:=xlDelimited, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="\"
r.Value = p
End Sub （マナ） 2023/09/28(木) 18:38:47
https://teratail.com/questions/270658
↑
これはフォルダだけなのでは？
先任のものと同じように見えます
マナさんのコードを一番下に追加しました
ファイルのリストが出ないです
やり方がおかしいのですかね？？
（はつ） 2023/10/04(水) 14:36:18
＞これはフォルダだけなのでは？ ＞先任のものと同じように見えます ＞やり方がおかしいのですかね？？
先生のコードは使用しません。 Sub test()を実行してください。
（マナ） 2023/10/04(水) 14:53:31
念のため、再確認してみたら フォルダ名が、001 のような場合、1（数値）になっちゃったので修正
Option Explicit
Sub test2()
Dim fdg As FileDialog
Dim p As String
Dim cmd As String, s
Dim r As Range
Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
If Not fdg.Show Then Exit Sub
p = fdg.SelectedItems(1)
cmd = "cmd /c dir """ & p & "\*.*"" /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
Set r = Worksheets.Add.Range("B10").Resize(UBound(s))
r.Value = Application.Transpose(s)
r.Replace p, "", xlPart
' r.Replace "\", "\'"
r.TextToColumns Destination:=r, DataType:=xlDelimited, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="\"
' r.EntireRow.Value = r.EntireRow.Value
r.Value = p
End Sub （マナ） 2023/10/04(水) 15:35:52
Set r = Worksheets.Add.Range("B10").Resize(UBound(s))
を
Set r = Worksheets("ファイル一覧取得").Range("B13").Resize(UBound(s))
としたけど失敗しました
ファイル一覧取得には表があって、その中に出力させたいです
教えてください
（はつ） 2023/10/24(火) 17:05:38
>としたけど失敗しました
具体的に説明してください。 （マナ） 2023/10/25(水) 16:28:42
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.