VBA 多階層

Question

以下は指定されたファイルを、サブフォルダの直下から取ってくるコードです

フォルダA------フォルダB------ファイルA
........... 　　　フォルダC------ファイルB
以上のような階層だと、ファイルAを取ってくるにはフォルダBを、ファイルBを取ってくるにはフォルダCを選択すれば取得できます。
やりたいことは、フォルダAを選択してファイルA、ファイルBを取得したいです。
条件式を変えたりしましたが、意味がないのかエラーや思い通りの動きになりません。
よろしくお願いします。

Button = MsgBox("貼り付けますか", vbYesNo + vbQuestion, "確認")

  If Button = vbYes Then

    With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show <> 0 Then
    
        myFolder = .SelectedItems(1) '選択したファイルを格納
        
    End If

    End With


    With CreateObject("WScript.Shell")
    
     .CurrentDirectory = myFolder
    
    End With

Filename = Dir("*テスト.xls*")
     '全てのサブフォルダの中にFilenameがあるか確認
Do While Filename <> "" 
    
    If Filename <> ThisWorkbook.Name Then
    
        IsBookOpen = False
        
        For Each OpenBook In Workbooks
                    
            If OpenBook.Name = Filename Then
            
                IsBookOpen = True
                
                Exit For
            Else
            
            End If
            
        Next
        'Filenameのファイルがあれば配列に格納
        If IsBookOpen = False Then
            ReDim Preserve file(a)
            file(a) = Filename
            a = a + 1
            
        End If
        
    End If
    Filename = Dir()
    
Loop

  Else
    MsgBox "キャンセルされました"
    
Exit Sub
    
End If


If a > 0 Then 'ファイルが存在するなら

Set open_file = Workbooks.Open(Filename:=myFolder & "\" & Filename, UpdateLinks:=False)

'以下略

Comments

[tosi]

こちらに同様な問い合わせがあります。
https://teratail.com/questions/282967
ファイル名がヒットしたら終了を追加で宜しいかと思います。
--------------------------------------------------------------
(追記)
上記URLと同じ方だったんですね。良く見ていませんでした。

[yakumo02]

皆さんありがとうございます。
自分の技術力を考え、再帰を選びました。

Answer 1

まず、サブフォルダのパスの一覧を作ってからですかね？

Option Explicit

Sub test()
    Dim myFolder As String
    Dim ResultsFolder() As String
    Dim ResultsFile() As String
    Dim buf As String
    Dim i As Long, j As Long
    Dim wb As Workbook
    myFolder = "C:\Users\m\Documents\てすと\"
    
    'サブフォルダーの検索
    buf = Dir(myFolder & "*.*", vbDirectory)
    Do While Len(buf) > 0
        buf = myFolder & buf
        If GetAttr(buf) And vbDirectory Then
            If Right(buf, 1) <> "." And Right(buf, 1) <> ".." Then
                ReDim Preserve ResultsFolder(i)
                ResultsFolder(i) = buf
                i = i + 1
            End If
        End If
        buf = Dir()
    Loop
    
    If Sgn(ResultsFolder) = 0 Then Exit Sub
    
    'サブフォルダーのファイルを検索
    For i = 0 To UBound(ResultsFolder)
        buf = Dir(ResultsFolder(i) & "*.xls?")
        Do While Len(buf) > 0
            ReDim Preserve ResultsFile(j)
            ResultsFile(i) = ResultsFolder(j) & "\" & buf
            j = j + 1
            buf = Dir()
        Loop
    Next
    
    If Sgn(ResultsFile) = 0 Then Exit Sub
    
    For i = 0 To UBound(ResultsFile)
        If ThisWorkbook.Name <> ResultsFile(i) Then
            Set wb = Workbooks.Open(ResultsFile(i))
            
            '何か処理
        
            wb.Close False
        End If
    Next
End Sub

時間ないのでバグあったらごめんなさい。

Answer 2

再帰呼び出しせずにやってみました。
myFolder取得後、以下でいかがでしょうか。

    Dim strCmd As String
    Dim objExec As Object
    
    With CreateObject("WScript.Shell")
        strCmd = "DIR/B/S " & myFolder & "\" & "*テスト.xls*"   '/B…ファイル名のみを表示、/S…指定されたディレクトリおよびそのサブディレクトリのすべてのファイルを表示
        Set objExec = .Exec("%ComSpec% /c " & strCmd)
        Do While objExec.Status = 0
            DoEvents
        Loop
        
        file() = Split(objExec.StdOut.ReadAll, vbCrLf)
        Set objExec = Nothing
    End With
    
    a = UBound(file) + 1

Answer 3

再帰などでサブフォルダを辿る必要があります。
サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）

**Dir()**では無く、FileSystemObjectを使う方法もあります。　
[VBA]サブフォルダ含むファイル一覧を再帰的に取得する